NCEPLIBS-w3emc  2.11.0
w3fp10.f
Go to the documentation of this file.
1 C> @file
2 C> @brief Printer contour subroutine.
3 C> @author Ralph Jones @date 1989-09-08
4 
5 C> Prints a two-dimensional grid of any shape, with
6 C> contouring, if desired. Grid values are scaled according to
7 C> to constants specified by the programer, rounded, and printed
8 C> as 4,3, or 2 digit integers with sign, the sign marking the
9 C> grid position of the printed number. If contouring is requested,
10 C> bessel's interpolation formula is used to optain the contour lines.
11 C> Contours are indicated by alphabetic characters ranging from a to
12 C> h or numeric characters from 0 to 9. Contour origin and interval
13 C> are specified by the programmer in terms of printed values.
14 C>
15 C> ### Program History Log
16 C> Date | Programmer | Comments
17 C> -----|------------|---------
18 C> 1989-09-08 | Ralph Jones | Initial
19 C> 1992-05-02 | Ralph Jones | Convert to cray cft77 fortran, add save.
20 C>
21 C> @param[in] RDATA Real array of grid data to be printed.
22 C> @param[in] KTBL Integer array with shape of array.
23 C> @param[in] CNST Real array of four elements, used in
24 C> scaling for printing and contouring.
25 C> @param[in] TITLE Is a array of 132 characters or less of
26 C> hollerith data, 1st char. must be blank.
27 C> printed at bottom of the map.
28 C> @param[in] KRECT 1 if grid is rectangular, 0 otherwise.
29 C> @param[in] KCONTR 1 for contouring , 0 otherwise.
30 C> @param[in] LINEV 0 is for 6 lines per vertical inch,
31 C> non-zero 8 lines per vertical inch.
32 C> @param[in] IWIDTH Number of characters in print line,
33 C> 132 is standard printer.
34 C>
35 C> Return conditions: Normal subroutine return, unless number of rows is
36 C> greater than 200, prints error message and exits.
37 C>
38 C> @note Special version of w3fp05(), 1st point is upper left hand
39 C> corner. Written on request of peter chase because some
40 C> grib fields can start with the upper left hand corner
41 C> as the 1st point of a grid.
42 C>
43 C> @author Ralph Jones @date 1989-09-08
44  SUBROUTINE w3fp10(RDATA,KTBL,CNST,TITLE,KRECT,KCONTR,
45  & LINEV,IWIDTH)
46 C
47  REAL CNST(4)
48  REAL RDATA(*)
49  REAL RWA(28)
50  REAL RWB(28)
51  REAL RWC(28)
52  REAL RWD(28)
53  REAL VDJA(29)
54  REAL VDJB(28)
55  REAL VDJC(28)
56 C
57  INTEGER TITLE(33)
58  INTEGER KRLOC(200)
59  INTEGER KTBL(*)
60  INTEGER OUTPUT
61  INTEGER PAGNL
62  INTEGER PAGNR
63  INTEGER PAGN3
64  INTEGER PCCNT
65  INTEGER PCFST
66  INTEGER PGCNT
67  INTEGER PGCNTA
68  INTEGER PGFST
69  INTEGER PGFSTA
70  INTEGER PGMAX
71 C
72  LOGICAL DONE
73  LOGICAL LCNTR
74  LOGICAL RECT
75 C
76  CHARACTER*1 KALFA(16)
77  CHARACTER*1 KALPH(20)
78  CHARACTER*1 KHASTR
79  CHARACTER*1 KHBLNK
80  CHARACTER*1 KHDOLR
81  CHARACTER*1 KHMNS
82  CHARACTER*1 KHPLUS
83  CHARACTER*1 KHRSTR
84  CHARACTER*1 KHTBL(10)
85  CHARACTER*1 KLINE(126)
86  CHARACTER*1 KLINES(132)
87  CHARACTER*1 KNUMB(20)
88 C
89  equivalence(crmx,vdja(29))
90  equivalence(kline(1),klines(8))
91  equivalence(vdjc(1),rwa(1))
92 C
93 C ... THE VALUE CRMX IS MACHINE DEPENDENT, IT SHOULD BE
94 C ... SET TO A VALUE A LITTLE LESS THAN THE LARGEST POSITIVE
95 C ... FLOATING POINT NUMBER FOR THE COMPUTER.
96 C
97  SAVE
98 C> The value CRMX is machine dependent, it should be
99 C> set to a value a little less than the largest positive
100 C> floating point number for the computer.
101  DATA crmx /10.e70/
102  DATA kalfa /'A',' ','B',' ','C',' ','D',' ','E',' ','F',
103  & ' ','G',' ','H',' '/
104  DATA khastr/'*'/
105  DATA khblnk/' '/
106  DATA khdolr/'$'/
107  DATA khmns /'-'/
108  DATA khplus/'+'/
109  DATA khrstr/'1'/
110  DATA khtbl /'0','1','2','3','4','5','6','7','8','9'/
111 
112 C> LIMNRW is limit on number of rows allowed and is dimension of KRLOC
113  DATA limnrw/200/
114  DATA knumb /'0',' ','1',' ','2',' ','3',' ','4',' ',
115  & '5',' ','6',' ','7',' ','8',' ','9',' '/
116  DATA output/6/
117  DATA r5 /.2/
118  DATA r50 /.02/
119 C
120  8000 FORMAT (1h0,10x,44herror from w3fp10 ... number of rows in your,
121  & 9h array = ,i4,24h which exceeds limit of ,i4)
122  8100 FORMAT ( 1ht)
123  8200 FORMAT ( 1hs)
124  8300 FORMAT ( 1h ,/,1h ,/,1h )
125  8400 FORMAT ( 1h ,/,1h )
126  8500 FORMAT ( 132a1)
127  8600 FORMAT ( 33a4)
128 C
129 C COMPUTE VALUES FOR PRINTER WIDTH
130 C
131  IF (iwidth.GE.132.OR.iwidth.LE.0) pgmax = 25
132  IF (iwidth.GE.1.AND.iwidth.LE.22) pgmax = 3
133  IF (iwidth.GT.22.AND.iwidth.LT.132) pgmax = (iwidth-7) / 5
134  lw = (pgmax * 5 + 7) / 4
135  pagn3 = pgmax + 3
136  vdja(pagn3+1) = crmx
137  mxpg = pgmax * 5 + 7
138 C
139  IF (linev .NE. 0) THEN
140 C
141 C ...OTHERWISE LINEV IS NON-ZERO, SO 8 LINES/INCH IS DESIRED...
142 C
143  linate = 1
144  r4 = 0.250
145  r32 = 0.03125
146  con2 = 10.0
147  nbtwn = 3
148 C
149  ELSE
150 C
151  linate = 2
152  r4 = 0.33333333
153  r32 = 1.0 / 18.0
154  con2 = 6.0
155  nbtwn = 2
156  ENDIF
157 C
158  pgcnta = 0
159  pgfsta = 0
160  rect = .false.
161  done = .false.
162  kz = 0
163  kza = 1000
164  a = cnst(1)
165  kca = 2 * (1 - krect)
166 C
167 C TO SET NO. OF DIGITS TO BE PRINTED
168 C WHICH IS A FUNCTION OF THE TENS POSITION IN KCONTR
169 C
170  nodig = iabs(kcontr/10)
171  nodig = 3 - nodig
172 C
173 C WHERE C(NODIG) + 1 IS NO. OF DIGITS TO BE PRINTED
174 C
175  IF (nodig.LT.1 .OR. nodig.GT.3) nodig = 3
176 C
177 C ANY OUT-OF-RANGE WILL GET 4 DIGITS
178 C
179  lcntr = .false.
180  nconq = iabs(mod(kcontr,10))
181  IF (nconq .EQ. 0) GO TO 400
182  IF (nconq .LE. 2) GO TO 300
183 C
184 C OTHERWISE RESET NCONQ
185 C
186  nconq = 0
187  GO TO 400
188 C
189  300 CONTINUE
190  lcntr = .true.
191 C
192 C WITH NCONQ = 1 FOR LETTERS,AND = 2 FOR NUMBERS IN CONTOUR BANDS
193 C
194  400 CONTINUE
195  IF (nconq .NE. 2) THEN
196 C
197 C OTHERWISE SET AS LETTERS
198 C
199  kcow = 16
200  DO 500 j = 1,kcow
201  kalph(j) = kalfa(j)
202  500 CONTINUE
203 C
204  ELSE
205 C
206  kcow = 20
207  DO 700 j = 1,kcow
208  kalph(j) = knumb(j)
209  700 CONTINUE
210 C
211  ENDIF
212 C
213  radj = 4 * kcow
214  kd = 1
215 C
216 C *** SET UP TABLE OF INDICES CORRESPONDING TO FIRST ITEM IN EACH ROW
217 C *** THIS IS KRLOC
218 C *** PICK OUT SIZE AND ROW NUMBER OF LARGEST ROW (KCMX AND KCLMX)
219 C *** KZA LEFT-JUSTIFIES MAP IF ALL ROWS HAVE COMMON MINIMAL OFFSET
220 C
221  IF (ktbl(1 ).NE.(-1)) THEN
222 C
223 C *** ONE-DIMENSIONAL FORM
224 C
225  ktf = 3
226  kza = 0
227  imin = ktbl(2)
228  jmin = ktbl(3)
229  jmax = ktbl(3) + ktbl(1) - 1
230  nrws = ktbl(1)
231  IF (nrws .GT. limnrw) THEN
232  WRITE (output,8000) nrws , limnrw
233  RETURN
234  ENDIF
235  kc = 1
236 C
237  DO 1000 j = 1,nrws
238  krloc(j) = kd
239  IF (ktbl(kc+4) + ktbl(kc+3).LE.kz ) GO TO 900
240  kclmx = j
241  imax = ktbl(kc+4) + ktbl(kc+3)
242  kz = imax
243  kcmx = krloc(j) + ktbl(kc+4)
244  900 CONTINUE
245  kd = kd + ktbl(kc+4)
246  kc = kc + kca
247  1000 CONTINUE
248 C
249  ELSE
250 C
251 C *** TWO-DIMENSIONAL FORM
252 C *** THE TWO-DIMENSIONAL FORM IS COMPILER-DEPENDENT
253 C *** IT DEPENDS ON THE TWO-DIMENSIONAL ARRAY BEING STORED COLUMN-WISE
254 C *** THAT IS, WITH THE FIRST INDEX VARYING THE FASTEST
255 C
256  imin = ktbl(6)
257  jmin = ktbl(7)
258  nrws = ktbl(5)
259  IF (nrws .GT. limnrw) THEN
260  WRITE (output,8000) nrws , limnrw
261  RETURN
262  ENDIF
263 C
264  jmax = ktbl(7) + ktbl(5) -1
265  kc = 1
266  DO 1500 j = 1,nrws
267  krloc(j) = ktbl(2) * (ktbl(4)-nrws+j-1) + ktbl(kc+7) + 1
268  IF (ktbl(kc+7) + ktbl(kc+8).LE.kz) GO TO 1400
269  imax = ktbl(kc+7) + ktbl(kc+8)
270  kz = imax
271  kcmx = krloc(j) + ktbl(kc+8)
272  kclmx = j
273  1400 CONTINUE
274  IF (ktbl(kc+7).LT.kza) kza = ktbl(kc+7)
275  kc = kc + kca
276  1500 CONTINUE
277  imax = imax - kza
278  ktf = 7
279  ENDIF
280 C
281  pagnl = 0
282  pagnr = pgmax
283  IF (.NOT.lcntr) GO TO 1700
284  adc = (cnst(1) - cnst(4)) / cnst(3) + radj
285  bc = cnst(2) / cnst(3)
286 C
287 C *** PRINT I-LABELS ACROSS TOP OF MAP
288 C
289  1700 CONTINUE
290 C
291 C *** WHICH PREPARES CDC512 PRINTER FOR 8 LINES PER INCH
292 C
293  IF (linate.EQ.1) WRITE (output,8100)
294 C
295 C ...WHICH PREPARES PRINTER FOR 6 LINES PER INCH
296 C
297  IF (linate.EQ.2) WRITE (output,8200)
298  klines(1) = khrstr
299  kbr = 1
300  GO TO 6900
301 C
302  1800 CONTINUE
303  IF (.NOT.lcntr) GO TO 2000
304 C
305 C *** INITIALIZE CONTOUR WORKING AREA
306 C
307  DO 1900 j = 1,pagn3
308  rwc(j) = crmx
309  rwd(j) = crmx
310  1900 CONTINUE
311 C
312 C *** SET UP CONTOUR DATA AND PAGE LIMITERS FOR FIRST TWO ROWS
313 C
314  2000 CONTINUE
315  kra = 1
316  kc = ktf + 1
317  kbr = 2
318  GO TO 5900
319 C
320  2100 CONTINUE
321  kra = 2
322  kc = kc + kca
323  kbr = 3
324  GO TO 5900
325 C
326  2200 CONTINUE
327  kr = 0
328 C
329 C *** TEST IF THIS IS LAST PAGE
330 C
331  IF (imax.GT.pgmax-1) GO TO 2300
332  lmr = imax * 5 + 2
333  done = .true.
334 C
335 C *** DO LEFT J-LABELS
336 C
337  2300 CONTINUE
338  jcurr = jmin
339 C
340  2400 CONTINUE
341  kr = kr + 1
342  kra = kr + 2
343  kc = kc + kca
344  kta = mod(jcurr,10)
345  ktb = mod(jcurr,100)/10
346  ktc = mod(jcurr,1000)/100
347  IF (kr .EQ. 1 .OR. (.NOT. lcntr)) GO TO 2500
348  GO TO 2600
349 C
350  2500 CONTINUE
351  IF (linate.EQ.1) WRITE (output,8300)
352  IF (linate.EQ.2) WRITE (output,8400)
353 C
354  2600 CONTINUE
355  klines(2) = khplus
356  klines(1) = khblnk
357  IF (jcurr.LT.0) klines(2) = khmns
358  kta = iabs(kta)
359  ktb = iabs(ktb)
360  ktc = iabs(ktc)
361  IF (ktc .EQ. 0) GO TO 2700
362  klines(3) = khtbl(ktc+1)
363  klines(4) = khtbl(ktb+1)
364  klines(5) = khtbl(kta+1)
365  GO TO 2800
366 C
367  2700 CONTINUE
368  klines(3) = khtbl(ktb+1)
369  klines(4) = khtbl(kta+1)
370  klines(5) = khblnk
371 C
372  2800 CONTINUE
373  DO 2900 j = 6,mxpg
374  klines(j) = khblnk
375  2900 CONTINUE
376  IF (.NOT.done) GO TO 3000
377 C
378 C *** DO RIGHT J-LABELS IF LAST PAGE OF MAP
379 C
380  kline(lmr) = klines(2)
381  kline(lmr+1) = klines(3)
382  kline(lmr+2) = klines(4)
383  kline(lmr+3) = klines(5)
384 C
385 C *** FETCH AND CONVERT GRID VALUES TO A1 FORMAT FOR WHOLE LINE
386 C
387  3000 CONTINUE
388  krx = krloc(kr)
389  klx = 5 * pgfst + 1
390  IF (pgcnt.EQ.0) GO TO 4000
391  DO 3800 kk = 1,pgcnt
392  temp = rdata(krx) * cnst(2) + a
393  ktemp = abs(temp) + 0.5
394  kline(klx) = khplus
395  IF (temp.LT.0.0) kline(klx) = khmns
396  GO TO (3300,3200,3100),nodig
397  3100 CONTINUE
398  kta = mod(ktemp,10000)/1000
399 C
400  3200 CONTINUE
401  ktb = mod(ktemp,1000)/100
402 C
403  3300 CONTINUE
404  ktc = mod(ktemp,100)/10
405  ktd = mod(ktemp,10)
406  GO TO (3400,3500,3600),nodig
407 C
408  3400 CONTINUE
409  kline(klx+1) = khtbl(ktc+1)
410  kline(klx+2) = khtbl(ktd+1)
411  GO TO 3700
412 C
413  3500 CONTINUE
414  kline(klx+1) = khtbl(ktb+1)
415  kline(klx+2) = khtbl(ktc+1)
416  kline(klx+3) = khtbl(ktd+1)
417  GO TO 3700
418 C
419  3600 CONTINUE
420  kline(klx+1) = khtbl(kta+1)
421  kline(klx+2) = khtbl(ktb+1)
422  kline(klx+3) = khtbl(ktc+1)
423  kline(klx+4) = khtbl(ktd+1)
424 C
425  3700 CONTINUE
426  klx = klx + 5
427  krx = krx + 1
428  3800 CONTINUE
429 C
430 C *** FOLLOWING CHECKS FOR POLE POINT AND INSERTS PROPER CHARACTER.
431 C
432  IF (jcurr.NE.0) GO TO 4000
433  IF (imin.LT.(-25).OR.imin.GT.0) GO TO 4000
434  kx = -imin
435  IF (kx.LT.pgfst.AND.kx.GT.pgcnt+pgfst) GO TO 4000
436  kx = 5 * kx
437  IF (kline(kx+1).EQ.khmns) GO TO 3900
438  kline(kx) = khdolr
439  GO TO 4000
440 C
441  3900 CONTINUE
442  kline(kx+1) = khastr
443 C
444 C *** PRINT LINE OF MAP DATA
445 C
446  4000 CONTINUE
447  WRITE (output,8500) (klines(ii),ii=1,mxpg)
448  krloc(kr) = krx
449  jcurr = jcurr + 1
450 C JCURR = JCURR + JRWMP
451 C
452 C *** TEST BOTTOM OF MAP
453 C
454  IF (kr.EQ.nrws) GO TO 5700
455 C
456 C *** SET UP CONTOUR DATA AND PAGE LIMITERS FOR NEXT ROW
457 C
458  kbr = 4
459  GO TO 5900
460 C
461  4100 CONTINUE
462  IF (.NOT.lcntr) GO TO 2400
463 C
464 C *** DO CONTOURING
465 C
466  DO 4200 jj = 1,mxpg
467  klines(jj) = khblnk
468  4200 CONTINUE
469 C
470 C *** VERTICAL INTERPOLATIONS
471 C
472  DO 4700 kk = 1,pagn3
473  IF (rwb(kk).LT.crmx.AND.rwc(kk).LT.crmx) GO TO 4300
474  vdjb(kk) = crmx
475  vdjc(kk) = crmx
476  GO TO 4600
477 C
478  4300 CONTINUE
479  IF (rwa(kk).LT.crmx.AND.rwd(kk).LT.crmx) GO TO 4400
480  vdjc(kk) = 0.
481  GO TO 4500
482 C
483  4400 CONTINUE
484  vdjc(kk) = r32*(rwa(kk)+rwd(kk)-rwb(kk)-rwc(kk))
485 C
486  4500 CONTINUE
487  vdjb(kk) = r4*(rwc(kk)-rwb(kk)-con2*vdjc(kk))
488 C
489  4600 CONTINUE
490  vdja(kk)=rwb(kk)
491 C
492  4700 CONTINUE
493 C
494 C ...DO 2 OR 3 ROWS OF CONTOURING BETWEEN GRID ROWS...
495 C
496  DO 5600 ll = 1,nbtwn
497  DO 4800 kk = 1,pagn3
498  vdjb(kk) = vdjc(kk) + vdjb(kk)
499  vdja(kk) = vdjb(kk) + vdja(kk)
500  4800 CONTINUE
501 C
502 C ...WHERE VDJA HAS THE INTERPOLATED VALUE FOR THIS INTER-ROW
503 C *** HORIZONTAL INTERPOLATIONS
504 C
505  hdc = 0.0
506  IF (vdja(1).GE.crmx) GO TO 4900
507  hdc = r50*(vdja(4)+vdja(1)-vdja(2)-vdja(3))
508 C
509  4900 CONTINUE
510  kxb = 0
511  DO 5200 kk = 1,pgmax
512  IF (vdja(kk+1).GE.crmx) GO TO 5100
513  hda = vdja(kk+1)
514  IF (vdja(kk+2).GE.crmx) GO TO 5500
515  IF (vdja(kk+3).GE.crmx) hdc = 0.0
516  hdb = r5 * (vdja(kk+2) - vdja(kk+1) - 15.0 * hdc)
517 C
518 C *** COMPUTE AND STORE CONTOUR CHARACTERS, 5 PER POINT
519 C
520  khda = hda
521  kdb = iabs(mod(khda,kcow))
522  kline(kxb+1) = kalph(kdb+1)
523  DO 5000 jj = 2,5
524  hdb = hdb + hdc
525  hda = hda + hdb
526  khda = hda
527  kdb = iabs(mod(khda,kcow))
528  kxa = kxb + jj
529  kline(kxa) = kalph(kdb+1)
530  5000 CONTINUE
531  hdc = r50*(vdja(kk+4)+vdja(kk+1)-vdja(kk+2)-vdja(kk+3))
532  IF (vdja(kk+4).GE.crmx) hdc = 0.0
533 C
534  5100 CONTINUE
535  kxb = kxb + 5
536 C
537  5200 CONTINUE
538 C
539  5300 CONTINUE
540  WRITE (output,8500) (klines(ii),ii=1,mxpg)
541  DO 5400 kk = 1,mxpg
542  klines(kk) = khblnk
543  5400 CONTINUE
544  GO TO 5600
545 C
546  5500 CONTINUE
547  khda = hda
548  kdb = iabs(mod(khda,kcow))
549  kline(kxb+1) = kalph(kdb+1)
550  GO TO 5300
551 C
552  5600 CONTINUE
553  GO TO 2400
554 C
555  5700 CONTINUE
556  IF (linate.EQ.1) WRITE (output,8300)
557  IF (linate.EQ.2) WRITE (output,8400)
558  klines(1) = khblnk
559 C
560 C *** PRINT I-LABELS ACROSS BOTTOM OF PAGE
561 C
562  kbr = 5
563  GO TO 6900
564 C
565  5800 CONTINUE
566  IF (linate.EQ.1) WRITE (output,8300)
567  IF (linate.EQ.2) WRITE (output,8400)
568 C
569 C *** PRINT TITLE
570 C
571  WRITE (output,8600) (title(ii),ii=1,lw)
572 C
573 C *** TEST END OF MAP
574 C
575  IF (krloc(kclmx).EQ.kcmx) RETURN
576 C
577 C *** ADJUST PAGE LINE BOUNDARIES
578 C
579  IF (imax.GT.pgmax) imax = imax - pgmax
580  imin = ka
581  pagnl = pagnl + pgmax
582  pagnr = pagnr + pgmax
583  GO TO 1700
584 C
585 C *** ROUTINE TO PRE-STORE ROWS FOR CONTOURING AND COMPUTE LINE LIMITERS
586 C
587  5900 CONTINUE
588  pgfst = pgfsta
589  pgcnt = pgcnta
590  IF (kra.GT.nrws) GO TO 6800
591  krfst = ktbl(kc) - kza
592  krcnt = ktbl(kc+1)
593  kfx = krloc(kra)
594  IF (rect) GO TO 6100
595  IF (krfst-pagnl.LE.(-1)) GO TO 6400
596  pcfst = krfst - pagnl + 1
597  IF (pcfst.GE.pagn3) GO TO 6700
598  pgfsta = pcfst-1
599  pccnt = min(pagnr-krfst+2,krcnt)
600  IF (pgfsta.EQ.0) GO TO 6600
601  pgcnta = min(pagnr-krfst,krcnt)
602  IF (pgcnta.GT.0) GO TO 6000
603  pgcnta = 0
604  GO TO 6100
605 C
606  6000 CONTINUE
607  rect = krect.EQ.1.AND.pgcnta.LE.krcnt
608 C
609  6100 CONTINUE
610  IF (.NOT.lcntr) GO TO (1800,2100,2200,4100,5800) kbr
611  DO 6200 kk = 1,pagn3
612  rwa(kk) = rwb(kk)
613  rwb(kk) = rwc(kk)
614  rwc(kk) = rwd(kk)
615  rwd(kk) = crmx
616  6200 CONTINUE
617 C
618  IF (pccnt.EQ.0) GO TO (1800,2100,2200,4100,5800) kbr
619  kpc = pcfst + 1
620  DO 6300 kk = 1,pccnt
621  rwd(kpc) = rdata(kfx) * bc + adc
622  kfx = kfx + 1
623  kpc = kpc + 1
624  6300 CONTINUE
625  GO TO (1800,2100,2200,4100,5800) kbr
626 C
627  6400 CONTINUE
628  pcfst = 0
629  pgfsta = 0
630  kfx = kfx - 1
631  pccnt = krfst + krcnt - pagnl + 1
632  IF (pccnt.LT.pagn3) GO TO 6500
633  pccnt = pagn3
634  pgcnta = pgmax
635  GO TO 6100
636 C
637  6500 CONTINUE
638  IF (pccnt.GT.0) GO TO 6600
639  pgcnta = 0
640  pccnt = 0
641  GO TO 6100
642 C
643  6600 CONTINUE
644  pgcnta = min(pgmax,krcnt+krfst-pagnl)
645  GO TO 6100
646 C
647  6700 CONTINUE
648  pgcnta = 0
649 C
650  6800 CONTINUE
651  pccnt = 0
652  GO TO 6100
653 C
654 C *** ROUTINE TO PRINT I-LABELS
655 C
656  6900 CONTINUE
657  DO 7000 kk = 2,mxpg
658  klines(kk) = khblnk
659  7000 CONTINUE
660 C
661  kk = 1
662  ka = imin
663  lbl = min(imax,pgmax)
664 C
665  DO 7300 jj = 1,lbl
666  kline(kk) = khplus
667  IF (ka.LT.0) kline(kk) = khmns
668  kta = iabs(mod(ka,100)) / 10
669  ktb = iabs(mod(ka,10))
670  ktc = iabs(mod(ka,1000)) / 100
671  IF (ktc .EQ. 0) GO TO 7100
672  kline(kk+1) = khtbl(ktc+1)
673  kline(kk+2) = khtbl(kta+1)
674  kline(kk+3) = khtbl(ktb+1)
675  GO TO 7200
676 C
677  7100 CONTINUE
678  kline(kk+1) = khtbl(kta+1)
679  kline(kk+2) = khtbl(ktb+1)
680 C
681  7200 CONTINUE
682  kk = kk + 5
683  ka = ka + 1
684 C
685  7300 CONTINUE
686 C
687  WRITE (output,8500) (klines(ii),ii=1,mxpg)
688 C
689  GO TO (1800,2100,2200,4100,5800) kbr
690 C
691  7400 CONTINUE
692  RETURN
693 C
694  END
w3fp10
subroutine w3fp10(RDATA, KTBL, CNST, TITLE, KRECT, KCONTR, LINEV, IWIDTH)
Prints a two-dimensional grid of any shape, with contouring, if desired.
Definition: w3fp10.f:46