WAVEWATCH III  beta 0.0.1
w3arrymd.F90
Go to the documentation of this file.
1 #include "w3macros.h"
2 !/ ------------------------------------------------------------------- /
3 MODULE w3arrymd
4  !/
5  !/ +-----------------------------------+
6  !/ | WAVEWATCH III NOAA/NCEP |
7  !/ | H. L. Tolman |
8  !/ | FORTRAN 90 |
9  !/ | Last update : 30-Oct-2009 |
10  !/ +-----------------------------------+
11  !/
12  !/ Copyright 2009 National Weather Service (NWS),
13  !/ National Oceanic and Atmospheric Administration. All rights
14  !/ reserved. WAVEWATCH III is a trademark of the NWS.
15  !/ No unauthorized use without permission.
16  !/
17  ! 1. Purpose :
18  !
19  ! In this module all service routines for in and output (binary
20  ! and test) of arrays are gathered.
21  !
22  ! 2. Variables and types :
23  !
24  ! Name Type Scope Description
25  ! ----------------------------------------------------------------
26  ! ICOL Int. Private Number of collums four array output
27  ! (if not 80, 132 assumed).
28  ! NFRMAX Int. Private Max number of frequencies in 1D
29  ! print plots of spectra.
30  ! ----------------------------------------------------------------
31  !
32  ! 3. Subroutines and functions :
33  !
34  ! Name Type Scope Description
35  ! ----------------------------------------------------------------
36  ! INA2R Subr. Public Read 2D real array.
37  ! INA2I Subr. Public Read 2D integer array.
38  ! OUTA2R Subr. Public Write 2D real array.
39  ! OUTA2I Subr. Public Write 2D integer array.
40  ! OUTREA Subr. Public Print out 1D real array.
41  ! OUTINT Subr. Public Print out 1D integer array.
42  ! OUTMAT Subr. Public Print out 2D real array.
43  ! PRTBLK Subr. Public Print a block-type table of a 2D
44  ! real array.
45  ! PRT1DS Subr. Public Print plot of 1D spectrum.
46  ! PRT1DM Subr. Public Print plot of 1D spectra.
47  ! PRT2DS Subr. Public Print plot of 2D spectrum.
48  ! ANGSTR Subr. PRT2DS Convert direction to string.
49  ! ----------------------------------------------------------------
50  !
51  ! 4. Subroutines and functions used :
52  !
53  ! Name Type Module Description
54  ! ----------------------------------------------------------------
55  ! STRACE Subr. W3SERVMD Subroutine tracing. ( !/S )
56  ! ----------------------------------------------------------------
57  !
58  ! 5. Remarks :
59  !
60  ! 6. Switches :
61  !
62  ! !/S Enable subroutine tracing troughout module.
63  ! !/T Switch on test output for INA2R/I and OUTA2R/I.
64  !
65  ! 7. Source code :
66  !
67  !/ ------------------------------------------------------------------- /
68  PUBLIC
69  !
70  INTEGER, PARAMETER, PRIVATE :: ICOL = 80
71  INTEGER, PARAMETER, PRIVATE :: NFRMAX = 50
72  INTEGER, PARAMETER, PRIVATE :: NFM2 = nfrmax+1
73  !
74 CONTAINS
75  !/ ------------------------------------------------------------------- /
76  SUBROUTINE ina2r (ARRAY, MX, MY, LX, HX, LY, HY, &
77  NDS, NDST, NDSE, IDFM, RFORM, IDLA, VSC, VOF)
78  !/
79  !/ +-----------------------------------+
80  !/ | WAVEWATCH III NOAA/NCEP |
81  !/ | H. L. Tolman |
82  !/ | FORTRAN 90 |
83  !/ | Last update : 30-Oct-2009 |
84  !/ +-----------------------------------+
85  !/ Based on INAR2D by N.Booij, DUT.
86  !/
87  !/ 31-Mar-1993 : Final FORTRAN 77 ( version 1.18 )
88  !/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 )
89  !/ 30-Oct-2009 : Implement add offset argument. ( version 3.14 )
90  !/ (W. E. Rogers & T. J. Campbell, NRL)
91  !/ 20-Jan-2017 : Add error exit using EXTCDE. ( version 6.02 )
92  !/
93  ! 1. Purpose :
94  !
95  ! Reads 2-D array of pre-described layout and format.
96  !
97  ! 3. Parameter list
98  ! ----------------------------------------------------------------
99  ! ARRAY R.A. O Array to be read.
100  ! MX,MY Int. I Declared size of array.
101  ! LX,HX Int. I Range of x-counters to be read.
102  ! LY,HY Int. I Range of y-counters to be read.
103  ! NDS Int. I Unit number for dataset with array.
104  ! NDST Int. I Unit number for test output.
105  ! NDSE Int. I Unit number for error messages.
106  ! IDFM Int. I Format indicator.
107  ! IDFM = 1 : Free format.
108  ! IDFM = 2 : Fixed format RFORM.
109  ! IDFM = 3 : Unformatted.
110  ! RFORM C*(*) I Format, if IDFM = 2
111  ! IDLA Int. I Lay out indicator.
112  ! IDLA = 1 : Read for IY=LY-HY, IX=LX-HX,
113  ! IX line by IX line.
114  ! IDLA = 2 : Idem, one read statement.
115  ! IDLA = 3 : Read for IY=HY-LY, IX=LX,HX,
116  ! IX line by IX line.
117  ! IDLA = 4 : Idem, one read statement.
118  ! VSC Real I Scaling factor (multiplication).
119  ! VOF Real I Add offset.
120  ! ----------------------------------------------------------------
121  !
122  ! 4. Subroutines used :
123  !
124  ! See mudule documentation.
125  !
126  ! 5. Called by :
127  !
128  ! Any.
129  !
130  ! 6. Error messages :
131  !
132  ! See error escape locations at end of routine.
133  !
134  ! 8. Structure :
135  !
136  ! See comments in code.
137  !
138  ! 9. Switches :
139  !
140  ! !/S Enable subroutine tracing.
141  ! !/T Dump of input parameters in parameter list.
142  !
143  ! 10. Source code :
144  !
145  !/ ------------------------------------------------------------------- /
146  !/
147 #ifdef W3_S
148  USE w3servmd, ONLY: strace
149 #endif
150  USE w3servmd, ONLY: extcde
151  !
152  IMPLICIT NONE
153  !/
154  !/ ------------------------------------------------------------------- /
155  !/ Parameter list
156  !/
157  INTEGER, INTENT(IN) :: MX, MY, LX, HX, LY, HY, NDS, NDST, &
158  NDSE, IDFM, IDLA
159  REAL, INTENT(IN) :: VSC, VOF
160  CHARACTER, INTENT(IN) :: RFORM*(*)
161  REAL, INTENT(OUT) :: ARRAY(MX,MY)
162  !/
163  !/ ------------------------------------------------------------------- /
164  !/ Local parameters
165  !/
166  INTEGER :: IIDFM, IIDLA, IX, IY, ISTAT
167 #ifdef W3_S
168  INTEGER, SAVE :: IENT = 0
169 #endif
170  !/
171  !/ ------------------------------------------------------------------- /
172  !/
173 #ifdef W3_S
174  CALL strace (ient, 'INA2R')
175 #endif
176  !
177 #ifdef W3_T
178  WRITE (ndst,9000) mx, my, lx, hx, ly, hy, nds, ndst, ndse, &
179  idfm, rform, idla, vsc, vof
180 #endif
181  !
182  IF (idfm.LT.1 .OR. idfm.GT.3) THEN
183  iidfm = 1
184  ELSE
185  iidfm = idfm
186  END IF
187  IF (idla.LT.1 .OR. idla.GT.4) THEN
188  iidla = 1
189  ELSE
190  iidla = idla
191  END IF
192  !
193  ! Free format read :
194  !
195  IF (iidfm.EQ.1) THEN
196  IF (iidla.EQ.1) THEN
197  DO iy=ly, hy
198  READ (nds,*,END=800,ERR=801,IOSTAT=ISTAT) &
199  (array(ix,iy),ix=lx,hx)
200  END DO
201  ELSE IF (iidla.EQ.2) THEN
202  READ (nds,*,END=800,ERR=801,IOSTAT=ISTAT) &
203  ((array(ix,iy),ix=lx,hx),iy=ly,hy)
204  ELSE IF (iidla.EQ.3) THEN
205  DO iy=hy, ly, -1
206  READ (nds,*,END=800,ERR=801,IOSTAT=ISTAT) &
207  (array(ix,iy),ix=lx,hx)
208  END DO
209  ELSE
210  READ (nds,*,END=800,ERR=801,IOSTAT=ISTAT) &
211  ((array(ix,iy),ix=lx,hx),iy=hy,ly,-1)
212  END IF
213  !
214  ! Fixed format read :
215  !
216  ELSE IF (iidfm.EQ.2) THEN
217  IF (iidla.EQ.1) THEN
218  DO iy=ly, hy
219  READ (nds,rform,END=800,ERR=801,IOSTAT=ISTAT) &
220  (array(ix,iy),ix=lx,hx)
221  END DO
222  ELSE IF (iidla.EQ.2) THEN
223  READ (nds,rform,END=800,ERR=801,IOSTAT=ISTAT) &
224  ((array(ix,iy),ix=lx,hx),iy=ly,hy)
225  ELSE IF (iidla.EQ.3) THEN
226  DO iy=hy, ly, -1
227  READ (nds,rform,END=800,ERR=801,IOSTAT=ISTAT) &
228  (array(ix,iy),ix=lx,hx)
229  END DO
230  ELSE
231  READ (nds,rform,END=800,ERR=801,IOSTAT=ISTAT) &
232  ((array(ix,iy),ix=lx,hx),iy=hy,ly,-1)
233  END IF
234  !
235  ! Unformat read :
236  !
237  ELSE
238  IF (iidla.EQ.1) THEN
239  DO iy=ly, hy
240  READ (nds,END=800,ERR=801,IOSTAT=ISTAT) &
241  (array(ix,iy),ix=lx,hx)
242  END DO
243  ELSE IF (iidla.EQ.2) THEN
244  READ (nds,END=800,ERR=801,IOSTAT=ISTAT) &
245  ((array(ix,iy),ix=lx,hx),iy=ly,hy)
246  ELSE IF (iidla.EQ.3) THEN
247  DO iy=hy, ly, -1
248  READ (nds,END=800,ERR=801,IOSTAT=ISTAT) &
249  (array(ix,iy),ix=lx,hx)
250  END DO
251  ELSE
252  READ (nds,END=800,ERR=801,IOSTAT=ISTAT) &
253  ((array(ix,iy),ix=lx,hx),iy=hy,ly,-1)
254  END IF
255  END IF
256  !
257  ! Scaling :
258  !
259  DO ix=lx, hx
260  DO iy=ly, hy
261  array(ix,iy) = vsc * array(ix,iy) + vof
262  END DO
263  END DO
264  !
265  RETURN
266  !
267  ! Escape locations read errors :
268  !
269 800 CONTINUE
270  WRITE (ndse,900)
271  CALL extcde ( istat )
272  !
273 801 CONTINUE
274  WRITE (ndse,901) istat
275  CALL extcde ( istat )
276  !
277  ! Formats
278  !
279 900 FORMAT (/' *** ERROR INA2R : '/ &
280  ' PREMATURE END OF FILE'/)
281 901 FORMAT (/' *** ERROR INA2R : '/ &
282  ' ERROR IN READING FROM FILE'/ &
283  ' IOSTAT =',i5/)
284  !
285 #ifdef W3_T
286 9000 FORMAT (' TEST INA2R : INPUT :'/6x,8i4,2i3,1x,a,i3,2e12.4)
287 #endif
288  !/
289  !/ End of INA2R ----------------------------------------------------- /
290  !/
291  END SUBROUTINE ina2r
292  !/ ------------------------------------------------------------------- /
293  SUBROUTINE ina2i (ARRAY, MX, MY, LX, HX, LY, HY, &
294  NDS, NDST, NDSE, IDFM, RFORM, IDLA, VSC, VOF)
295  !/
296  !/ +-----------------------------------+
297  !/ | WAVEWATCH III NOAA/NCEP |
298  !/ | H. L. Tolman |
299  !/ | FORTRAN 90 |
300  !/ | Last update : 30-Oct-2009 |
301  !/ +-----------------------------------+
302  !/ Based on INAR2D by N.Booij, DUT.
303  !/
304  !/ 31-Mar-1993 : Final FORTRAN 77 ( version 1.18 )
305  !/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 )
306  !/ 30-Oct-2009 : Implement add offset argument. ( version 3.14 )
307  !/ (W. E. Rogers & T. J. Campbell, NRL)
308  !/ 20-Jan-2017 : Add error exit using EXTCDE. ( version 6.02 )
309  !/
310  ! 1. Purpose :
311  !
312  ! Like INA2R , integer ARRAY, VSC and VOF, see INA2R .
313  !
314  ! 10. Source code :
315  !
316  !/ ------------------------------------------------------------------- /
317  !/
318 #ifdef W3_S
319  USE w3servmd, ONLY: strace
320 #endif
321  USE w3servmd, ONLY: extcde
322  !
323  IMPLICIT NONE
324  !/
325  !/ ------------------------------------------------------------------- /
326  !/ Parameter list
327  !/
328  INTEGER, INTENT(IN) :: MX, MY, LX, HX, LY, HY, NDS, NDST, &
329  NDSE, IDFM, IDLA, VSC, VOF
330  INTEGER, INTENT(OUT) :: ARRAY(MX,MY)
331  CHARACTER, INTENT(IN) :: RFORM*(*)
332  !/
333  !/ ------------------------------------------------------------------- /
334  !/ Local parameters
335  !/
336  INTEGER :: IIDFM, IIDLA, IX, IY, ISTAT
337 #ifdef W3_S
338  INTEGER, SAVE :: IENT = 0
339 #endif
340  !/
341  !/ ------------------------------------------------------------------- /
342  !/
343 #ifdef W3_S
344  CALL strace (ient, 'INA2I')
345 #endif
346  !
347 #ifdef W3_T
348  WRITE (ndst,9000) mx, my, lx, hx, ly, hy, nds, ndst, ndse, &
349  idfm, rform, idla, vsc, vof
350 #endif
351  !
352  IF (idfm.LT.1 .OR. idfm.GT.3) THEN
353  iidfm = 1
354  ELSE
355  iidfm = idfm
356  END IF
357  IF (idla.LT.1 .OR. idla.GT.4)THEN
358  iidla = 1
359  ELSE
360  iidla = idla
361  END IF
362  !
363  ! Free format read :
364  !
365  IF (iidfm.EQ.1) THEN
366  IF (iidla.EQ.1) THEN
367  DO iy=ly, hy
368  READ (nds,*,END=800,ERR=801,IOSTAT=ISTAT) &
369  (array(ix,iy),ix=lx,hx)
370  END DO
371  ELSE IF (iidla.EQ.2) THEN
372  READ (nds,*,END=800,ERR=801,IOSTAT=ISTAT) &
373  ((array(ix,iy),ix=lx,hx),iy=ly,hy)
374  ELSE IF (iidla.EQ.3) THEN
375  DO iy=hy, ly, -1
376  READ (nds,*,END=800,ERR=801,IOSTAT=ISTAT) &
377  (array(ix,iy),ix=lx,hx)
378  END DO
379  ELSE
380  READ (nds,*,END=800,ERR=801,IOSTAT=ISTAT) &
381  ((array(ix,iy),ix=lx,hx),iy=hy,ly,-1)
382  END IF
383  !
384  ! Fixed format read :
385  !
386  ELSE IF (iidfm.EQ.2) THEN
387  IF (iidla.EQ.1) THEN
388  DO iy=ly, hy
389  READ (nds,rform,END=800,ERR=801,IOSTAT=ISTAT) &
390  (array(ix,iy),ix=lx,hx)
391  END DO
392  ELSE IF (iidla.EQ.2) THEN
393  READ (nds,rform,END=800,ERR=801,IOSTAT=ISTAT) &
394  ((array(ix,iy),ix=lx,hx),iy=ly,hy)
395  ELSE IF (iidla.EQ.3) THEN
396  DO iy=hy, ly, -1
397  READ (nds,rform,END=800,ERR=801,IOSTAT=ISTAT) &
398  (array(ix,iy),ix=lx,hx)
399  END DO
400  ELSE
401  READ (nds,rform,END=800,ERR=801,IOSTAT=ISTAT) &
402  ((array(ix,iy),ix=lx,hx),iy=hy,ly,-1)
403  END IF
404  !
405  ! Unformat read :
406  !
407  ELSE
408  IF (iidla.EQ.1) THEN
409  DO iy=ly, hy
410  READ (nds,END=800,ERR=801,IOSTAT=ISTAT) &
411  (array(ix,iy),ix=lx,hx)
412  END DO
413  ELSE IF (iidla.EQ.2) THEN
414  READ (nds,END=800,ERR=801,IOSTAT=ISTAT) &
415  ((array(ix,iy),ix=lx,hx),iy=ly,hy)
416  ELSE IF (iidla.EQ.3) THEN
417  DO iy=hy, ly, -1
418  READ (nds,END=800,ERR=801,IOSTAT=ISTAT) &
419  (array(ix,iy),ix=lx,hx)
420  END DO
421  ELSE
422  READ (nds,END=800,ERR=801,IOSTAT=ISTAT) &
423  ((array(ix,iy),ix=lx,hx),iy=hy,ly,-1)
424  END IF
425  END IF
426  !
427  ! Scaling :
428  !
429  DO ix=lx, hx
430  DO iy=ly, hy
431  array(ix,iy) = vsc * array(ix,iy) + vof
432  END DO
433  END DO
434  !
435  RETURN
436  !
437  ! Escape locations read errors :
438  !
439 800 CONTINUE
440  WRITE (ndse,900)
441  CALL extcde ( istat )
442  !
443 801 CONTINUE
444  WRITE (ndse,901) istat
445  CALL extcde ( istat )
446  !
447  ! Formats
448  !
449 900 FORMAT (/' *** ERROR INA2I : '/ &
450  ' PREMATURE END OF FILE'/)
451 901 FORMAT (/' *** ERROR INA2I : '/ &
452  ' ERROR IN READING FROM FILE'/ &
453  ' IOSTAT =',i5/)
454  !
455 #ifdef W3_T
456 9000 FORMAT (' TEST INA2I : INPUT :'/6x,8i4,2i3,1x,a,i3,2i5)
457 #endif
458  !/
459  !/ End of INA2I ----------------------------------------------------- /
460  !/
461  END SUBROUTINE ina2i
462  !/ ------------------------------------------------------------------- /
463  SUBROUTINE outa2r (ARRAY, MX, MY, LX, HX, LY, HY, &
464  NDS, NDST, NDSE, IDFM, RFORM, IDLA, VSC, VOF)
465  !/
466  !/ +-----------------------------------+
467  !/ | WAVEWATCH III NOAA/NCEP |
468  !/ | H. L. Tolman |
469  !/ | FORTRAN 90 |
470  !/ | Last update : 30-Oct-2009 |
471  !/ +-----------------------------------+
472  !/
473  !/ 31-Mar-1993 : Final FORTRAN 77 ( version 1.18 )
474  !/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 )
475  !/ 21-Feb-2008 ; Bug fix IDFM=1, IDLA=2 writing ( version 3.13 )
476  !/ 30-Oct-2009 ; Fix non-integer loop bound. ( version 3.14 )
477  !/ (T. J. Campbell, NRL)
478  !/ 30-Oct-2009 : Implement add offset argument. ( version 3.14 )
479  !/ (W. E. Rogers & T. J. Campbell, NRL)
480  !/ 20-Jan-2017 : Add error exit using EXTCDE. ( version 6.02 )
481  !/
482  ! 1. Purpose :
483  !
484  ! Writes 2-D array of pre-described layout and format. "Inverse"
485  ! version of INA2R . For documentation see INA2R .
486  !
487  ! N.B. - ARRAY_OUT <= ( ARRAY_IN - VOF ) / VSC
488  ! - No error trapping on write.
489  !
490  ! 10. Source code :
491  !
492  !/ ------------------------------------------------------------------- /
493  !/
494 #ifdef W3_S
495  USE w3servmd, ONLY: strace
496 #endif
497  USE w3servmd, ONLY: extcde
498  !
499  IMPLICIT NONE
500  !/
501  !/ ------------------------------------------------------------------- /
502  !/ Parameter list
503  !/
504  INTEGER, INTENT(IN) :: MX, MY, LX, HX, LY, HY, NDS, NDST, &
505  NDSE, IDFM, IDLA
506  REAL, INTENT(IN) :: VSC, VOF, ARRAY(MX,MY)
507  CHARACTER, INTENT(IN) :: RFORM*(*)
508  !/
509  !/ ------------------------------------------------------------------- /
510  !/ Local parameters
511  !/
512  INTEGER :: IIDFM, IIDLA, IX, IY, ISTAT
513 #ifdef W3_S
514  INTEGER, SAVE :: IENT = 0
515 #endif
516  !/
517  !/ ------------------------------------------------------------------- /
518  !/
519 #ifdef W3_S
520  CALL strace (ient, 'OUTA2R')
521 #endif
522  !
523 #ifdef W3_T
524  WRITE (ndst,9000) mx, my, lx, hx, ly, hy, nds, ndst, ndse, &
525  idfm, rform, idla, vsc, vof
526 #endif
527  !
528  IF (idfm.LT.1 .OR. idfm.GT.3) THEN
529  iidfm = 1
530  ELSE
531  iidfm = idfm
532  END IF
533  IF (idla.LT.1 .OR. idla.GT.4) THEN
534  iidla = 1
535  ELSE
536  iidla = idla
537  END IF
538  !
539  ! Free format write :
540  !
541  IF (iidfm.EQ.1) THEN
542  IF (iidla.EQ.1) THEN
543  DO iy=ly, hy
544  WRITE (nds,*,err=800,iostat=istat) &
545  ((array(ix,iy)-vof)/vsc,ix=lx,hx)
546  END DO
547  ELSE IF (iidla.EQ.2) THEN
548  WRITE (nds,*,err=800,iostat=istat) &
549  (((array(ix,iy)-vof)/vsc,ix=lx,int(hx/vsc)),iy=ly,hy)
550  ELSE IF (iidla.EQ.3) THEN
551  DO iy=hy, ly, -1
552  WRITE (nds,*,err=800,iostat=istat) &
553  ((array(ix,iy)-vof)/vsc,ix=lx,hx)
554  END DO
555  ELSE
556  WRITE (nds,*,err=800,iostat=istat) &
557  (((array(ix,iy)-vof)/vsc,ix=lx,hx),iy=hy,ly,-1)
558  END IF
559  !
560  ! Fixed format write :
561  !
562  ELSE IF (iidfm.EQ.2) THEN
563  IF (iidla.EQ.1) THEN
564  DO iy=ly, hy
565  WRITE (nds,rform,err=800,iostat=istat) &
566  ((array(ix,iy)-vof)/vsc,ix=lx,hx)
567  END DO
568  ELSE IF (iidla.EQ.2) THEN
569  WRITE (nds,rform,err=800,iostat=istat) &
570  (((array(ix,iy)-vof)/vsc,ix=lx,hx),iy=ly,hy)
571  ELSE IF (iidla.EQ.3) THEN
572  DO iy=hy, ly, -1
573  WRITE (nds,rform,err=800,iostat=istat) &
574  ((array(ix,iy)-vof)/vsc,ix=lx,hx)
575  END DO
576  ELSE
577  WRITE (nds,rform,err=800,iostat=istat) &
578  (((array(ix,iy)-vof)/vsc,ix=lx,hx),iy=hy,ly,-1)
579  END IF
580  !
581  ! Unformat write :
582  !
583  ELSE
584  IF (iidla.EQ.1) THEN
585  DO iy=ly, hy
586  WRITE (nds,err=800,iostat=istat) &
587  ((array(ix,iy)-vof)/vsc,ix=lx,hx)
588  END DO
589  ELSE IF (iidla.EQ.2) THEN
590  WRITE (nds,err=800,iostat=istat) &
591  (((array(ix,iy)-vof)/vsc,ix=lx,hx),iy=ly,hy)
592  ELSE IF (iidla.EQ.3) THEN
593  DO iy=hy, ly, -1
594  WRITE (nds,err=800,iostat=istat) &
595  ((array(ix,iy)-vof)/vsc,ix=lx,hx)
596  END DO
597  ELSE
598  WRITE (nds,err=800,iostat=istat) &
599  (((array(ix,iy)-vof)/vsc,ix=lx,hx),iy=hy,ly,-1)
600  END IF
601  END IF
602  !
603  RETURN
604  !
605  ! Escape locations write errors :
606  !
607 800 CONTINUE
608  WRITE (ndse,900) istat
609  CALL extcde ( istat )
610  !
611  ! Formats
612  !
613 900 FORMAT (/' *** ERROR OUTA2R : '/ &
614  ' ERROR IN WRITING TO FILE'/ &
615  ' IOSTAT =',i5/)
616  !
617 #ifdef W3_T
618 9000 FORMAT (' TEST OUTA2R : INPUT :'/6x,8i4,2i3,1x,a,i3,2e12.4)
619 #endif
620  !/
621  !/ End of OUTA2R ----------------------------------------------------- /
622  !/
623  END SUBROUTINE outa2r
624  !/ ------------------------------------------------------------------- /
625  SUBROUTINE outa2i (ARRAY, MX, MY, LX, HX, LY, HY, &
626  NDS, NDST, NDSE, IDFM, RFORM, IDLA, VSC, VOF)
627  !/
628  !/ +-----------------------------------+
629  !/ | WAVEWATCH III NOAA/NCEP |
630  !/ | H. L. Tolman |
631  !/ | FORTRAN 90 |
632  !/ | Last update : 30-Oct-2009 |
633  !/ +-----------------------------------+
634  !/
635  !/ 31-Mar-1993 : Final FORTRAN 77 ( version 1.18 )
636  !/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 )
637  !/ 30-Oct-2009 : Implement add offset argument. ( version 3.14 )
638  !/ (W. E. Rogers & T. J. Campbell, NRL)
639  !/ 20-Jan-2017 : Add error exit using EXTCDE. ( version 6.02 )
640  !/
641  ! 1. Purpose :
642  !
643  ! Like OUTA2R, integer ARRAY, VSC and VOF, see OUTA2R.
644  !
645  ! 10. Source code :
646  !
647  !/ ------------------------------------------------------------------- /
648  !/
649 #ifdef W3_S
650  USE w3servmd, ONLY: strace
651 #endif
652  USE w3servmd, ONLY: extcde
653  !
654  IMPLICIT NONE
655  !/
656  !/ ------------------------------------------------------------------- /
657  !/ Parameter list
658  !/
659  INTEGER, INTENT(IN) :: MX, MY, LX, HX, LY, HY, NDS, NDST, &
660  NDSE, IDFM, IDLA, ARRAY(MX,MY)
661  INTEGER, INTENT(IN) :: VSC, VOF
662  CHARACTER, INTENT(IN) :: RFORM*(*)
663  !/
664  !/ ------------------------------------------------------------------- /
665  !/ Local parameters
666  !/
667  INTEGER :: IIDFM, IIDLA, IX, IY, ISTAT
668 #ifdef W3_S
669  INTEGER, SAVE :: IENT = 0
670 #endif
671  !/
672  !/ ------------------------------------------------------------------- /
673  !/
674 #ifdef W3_S
675  CALL strace (ient, 'OUTA2I')
676 #endif
677  !
678 #ifdef W3_T
679  WRITE (ndst,9000) mx, my, lx, hx, ly, hy, nds, ndst, ndse, &
680  idfm, rform, idla, vsc, vof
681 #endif
682  !
683  IF (idfm.LT.1 .OR. idfm.GT.3) THEN
684  iidfm = 1
685  ELSE
686  iidfm = idfm
687  END IF
688  IF (idla.LT.1 .OR. idla.GT.4) THEN
689  iidla = 1
690  ELSE
691  iidla = idla
692  END IF
693  !
694  ! Free format write :
695  !
696  IF (iidfm.EQ.1) THEN
697  IF (iidla.EQ.1) THEN
698  DO iy=ly, hy
699  WRITE (nds,*,err=800,iostat=istat) &
700  ((array(ix,iy)-vof)/vsc,ix=lx,hx)
701  END DO
702  ELSE IF (iidla.EQ.2) THEN
703  WRITE (nds,*,err=800,iostat=istat) &
704  (((array(ix,iy)-vof)/vsc,ix=lx,hx),iy=ly,hy)
705  ELSE IF (iidla.EQ.3) THEN
706  DO iy=hy, ly, -1
707  WRITE (nds,*,err=800,iostat=istat) &
708  ((array(ix,iy)-vof)/vsc,ix=lx,hx)
709  END DO
710  ELSE
711  WRITE (nds,*,err=800,iostat=istat) &
712  (((array(ix,iy)-vof)/vsc,ix=lx,hx),iy=hy,ly,-1)
713  END IF
714  !
715  ! Fixed format write :
716  !
717  ELSE IF (iidfm.EQ.2) THEN
718  IF (iidla.EQ.1) THEN
719  DO iy=ly, hy
720  WRITE (nds,rform,err=800,iostat=istat) &
721  ((array(ix,iy)-vof)/vsc,ix=lx,hx)
722  END DO
723  ELSE IF (iidla.EQ.2) THEN
724  WRITE (nds,rform,err=800,iostat=istat) &
725  (((array(ix,iy)-vof)/vsc,ix=lx,hx),iy=ly,hy)
726  ELSE IF (iidla.EQ.3) THEN
727  DO iy=hy, ly, -1
728  WRITE (nds,rform,err=800,iostat=istat) &
729  ((array(ix,iy)-vof)/vsc,ix=lx,hx)
730  END DO
731  ELSE
732  WRITE (nds,rform,err=800,iostat=istat) &
733  (((array(ix,iy)-vof)/vsc,ix=lx,hx),iy=hy,ly,-1)
734  END IF
735  !
736  ! Unformat write :
737  !
738  ELSE
739  IF (iidla.EQ.1) THEN
740  DO iy=ly, hy
741  WRITE (nds,err=800,iostat=istat) &
742  ((array(ix,iy)-vof)/vsc,ix=lx,hx)
743  END DO
744  ELSE IF (iidla.EQ.2) THEN
745  WRITE (nds,err=800,iostat=istat) &
746  (((array(ix,iy)-vof)/vsc,ix=lx,hx),iy=ly,hy)
747  ELSE IF (iidla.EQ.3) THEN
748  DO iy=hy, ly, -1
749  WRITE (nds,err=800,iostat=istat) &
750  ((array(ix,iy)-vof)/vsc,ix=lx,hx)
751  END DO
752  ELSE
753  WRITE (nds,err=800,iostat=istat) &
754  (((array(ix,iy)-vof)/vsc,ix=lx,hx),iy=hy,ly,-1)
755  END IF
756  END IF
757  !
758  RETURN
759  !
760  ! Escape locations write errors :
761  !
762 800 CONTINUE
763  WRITE (ndse,900) istat
764  CALL extcde ( istat )
765  !
766  ! Formats
767  !
768 900 FORMAT (/' *** ERROR OUTA2I : '/ &
769  ' ERROR IN WRITING TO FILE'/ &
770  ' IOSTAT =',i5/)
771  !
772 #ifdef W3_T
773 9000 FORMAT (' TEST OUTA2I : INPUT :'/6x,8i4,2i3,1x,a,i3,2i5)
774 #endif
775  !/
776  !/ End of OUTA2I ----------------------------------------------------- /
777  !/
778  END SUBROUTINE outa2i
779  !/ ------------------------------------------------------------------- /
780  SUBROUTINE outrea (NDS,ARRAY,DIM,ANAME)
781  !/
782  !/ +-----------------------------------+
783  !/ | WAVEWATCH III NOAA/NCEP |
784  !/ | H. L. Tolman |
785  !/ | FORTRAN 90 |
786  !/ | Last update : 29-Nov-1999 |
787  !/ +-----------------------------------+
788  !/ Original versions G. Ph. van Vledder
789  !/ P. H. Willems
790  !/
791  !/ 29-Mar-1993 : Final FORTRAN 77 ( version 1.18 )
792  !/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 )
793  !/
794  ! 1. Purpose :
795  !
796  ! Print contents of a 1-D real array, see OUTINT.
797  !
798  !/ ------------------------------------------------------------------- /
799  !/
800 #ifdef W3_S
801  USE w3servmd, ONLY: strace
802 #endif
803  !
804  IMPLICIT NONE
805  !/
806  !/ ------------------------------------------------------------------- /
807  !/ Parameter list
808  !/
809  INTEGER, INTENT(IN) :: NDS, DIM
810  REAL, INTENT(IN) :: ARRAY(DIM)
811  CHARACTER, INTENT(IN) :: ANAME*(*)
812  !/
813  !/ ------------------------------------------------------------------- /
814  !/ Local parameters
815  !/
816  INTEGER :: I, K
817 #ifdef W3_S
818  INTEGER, SAVE :: IENT = 0
819 #endif
820  !/
821  !/ ------------------------------------------------------------------- /
822  !/
823 #ifdef W3_S
824  CALL strace (ient, 'OUTREA')
825 #endif
826  !
827  WRITE (nds,8000) aname
828  !
829  IF (icol.EQ.80) THEN
830  !
831  WRITE (nds,8005) (i, i=1, 5)
832  WRITE (nds,8010)
833  DO k=0, dim, 5
834  IF (dim-k.GE.5) THEN
835  WRITE (nds,'(1X,I4,A,5E12.4,A)') &
836  k,' |',(array(i),i= k+1, k+5),' |'
837  ELSE
838  WRITE (nds,'(1X,T71,''|'',T2,I4,A,5E12.4)') &
839  k,' |',(array(i),i= k+1, dim)
840  END IF
841  END DO
842  WRITE (nds,8010)
843  !
844  ELSE
845  !
846  WRITE (nds,9005) (i, i=1, 10)
847  WRITE (nds,9010)
848  DO k=0, dim, 10
849  IF (dim-k.GE.10) THEN
850  WRITE (nds,'(1X,I4,A,10E12.4,A)') &
851  k,' |',(array(i),i= k+1, k+10),' |'
852  ELSE
853  WRITE (nds,'(1X,T131,''|'',T2,I4,A,10E12.4)') &
854  k,' |',(array(i),i= k+1, dim)
855  END IF
856  END DO
857  WRITE (nds,9010)
858  END IF
859  !
860  RETURN
861  !
862 8000 FORMAT (/,1x,'A R R A Y D U M P (REAL) / NAME: ',a)
863 8005 FORMAT (8x,5i12)
864 8010 FORMAT (7x,'+',62('-'),'+')
865 9005 FORMAT (8x,10i12)
866 9010 FORMAT (7x,'+',122('-'),'+')
867  !/
868  !/ End of OUTREA ----------------------------------------------------- /
869  !/
870  END SUBROUTINE outrea
871  !/ ------------------------------------------------------------------- /
872  SUBROUTINE outint ( NDS, IARRAY, DIM, ANAME )
873  !/
874  !/ +-----------------------------------+
875  !/ | WAVEWATCH III NOAA/NCEP |
876  !/ | H. L. Tolman |
877  !/ | FORTRAN 90 |
878  !/ | Last update : 29-Mar-1993 |
879  !/ +-----------------------------------+
880  !/ Original versions G. Ph. van Vledder
881  !/ P. H. Willems
882  !/
883  !/ 29-Mar-1993 : Final FORTRAN 77 ( version 1.18 )
884  !/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 )
885  !/
886  ! 1. Purpose :
887  !
888  ! Print contents of a 1-D integer array.
889  !
890  ! 2. Method :
891  !
892  ! 3. Parameters :
893  !
894  ! Parameter list
895  ! ----------------------------------------------------------------
896  ! NDS Int. I Output unit number.
897  ! IARRAY I.A. I Array to be printed.
898  ! DIM Int. I Number of elements to be printed.
899  ! ANAME C*(*) I Name of array.
900  ! ----------------------------------------------------------------
901  !
902  ! 4. Subroutines used :
903  !
904  ! See mudule documentation.
905  !
906  ! 5. Called by :
907  !
908  ! Anny routine or program.
909  !
910  ! 10. Source code :
911  !
912  !/ ------------------------------------------------------------------- /
913  !/
914 #ifdef W3_S
915  USE w3servmd, ONLY: strace
916 #endif
917  !
918  IMPLICIT NONE
919  !/
920  !/ ------------------------------------------------------------------- /
921  !/ Parameter list
922  !/
923  INTEGER, INTENT(IN) :: NDS, DIM, IARRAY(DIM)
924  CHARACTER, INTENT(IN) :: ANAME*(*)
925  !/
926  !/ ------------------------------------------------------------------- /
927  !/ Local parameters
928  !/
929  INTEGER :: I, K
930 #ifdef W3_S
931  INTEGER, SAVE :: IENT = 0
932 #endif
933  !/
934  !/ ------------------------------------------------------------------- /
935  !/
936 #ifdef W3_S
937  CALL strace (ient, 'OUTINT')
938 #endif
939  !
940  WRITE (nds,8000) aname
941  !
942  ! ------- 80 COLUMNS -----
943  !
944  IF (icol.EQ.80) THEN
945  WRITE (nds,8005) (i, i=1, 5)
946  WRITE (nds,8010)
947  DO k=0, dim, 5
948  IF (dim-k.GE.5) THEN
949  WRITE (nds,'(1X,I4,A,5I12,A)') &
950  k,' |',(iarray(i),i= k+1, k+5),' |'
951  ELSE
952  WRITE (nds,'(1X,T71,''|'',T2,I4,A,5I12)') &
953  k,' |',(iarray(i),i= k+1, dim)
954  END IF
955  END DO
956  WRITE (nds,8010)
957  ELSE
958  !
959  ! ---- 132 COLUMNS ----
960  !
961  WRITE (nds,9005) (i, i=1, 10)
962  WRITE (nds,9010)
963  DO k=0, dim, 10
964  IF (dim-k.GE.10) THEN
965  WRITE (nds,'(1X,I4,A,10I12,A)') &
966  k,' |',(iarray(i),i= k+1, k+10),' |'
967  ELSE
968  WRITE (nds,'(1X,T131,''|'',T2,I4,A,10I12)') &
969  k,' |',(iarray(i),i= k+1, dim)
970  END IF
971  END DO
972  WRITE (nds,9010)
973  END IF
974  !
975  RETURN
976  !
977 8000 FORMAT (/,1x,'A R R A Y D U M P (INTEGER) / NAME: ',a)
978 8005 FORMAT (8x,5i12)
979 8010 FORMAT (7x,'+',62('-'),'+')
980 9005 FORMAT (8x,10i12)
981 9010 FORMAT (7x,'+',122('-'),'+')
982  !/
983  !/ End of OUTINT ----------------------------------------------------- /
984  !/
985  END SUBROUTINE outint
986  !/ ------------------------------------------------------------------- /
987  SUBROUTINE outmat (NDS,A,MX,NX,NY,MNAME)
988  !/
989  !/ +-----------------------------------+
990  !/ | WAVEWATCH III NOAA/NCEP |
991  !/ | H. L. Tolman |
992  !/ | FORTRAN 90 |
993  !/ | Last update : 29-Nov-1999 |
994  !/ +-----------------------------------+
995  !/ Original versions G. Ph. van Vledder
996  !/
997  !/ 29-Mar-1993 : Final FORTRAN 77 ( version 1.18 )
998  !/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 )
999  !/
1000  ! 1. Purpose :
1001  !
1002  ! Print contents of a 2-D real array.
1003  !
1004  ! 2. Method :
1005  !
1006  ! 3. Parameters :
1007  !
1008  ! Parameter list
1009  ! ----------------------------------------------------------------
1010  ! NDS Int. I Output unit number.
1011  ! A R.A. I Matrix to be printed.
1012  ! MX Int. I Dimension of first index.
1013  ! NX Int. I Number of points for first index.
1014  ! NY Int. I Number of points for scond index.
1015  ! MNAME C*(*) I Name of matrix.
1016  ! ----------------------------------------------------------------
1017  !
1018  ! 4. Subroutines used :
1019  !
1020  ! See mudule documentation.
1021  !
1022  ! 5. Called by :
1023  !
1024  ! Anny routine or program.
1025  !
1026  ! 10. Source code :
1027  !
1028  !/ ------------------------------------------------------------------- /
1029  !/
1030 #ifdef W3_S
1031  USE w3servmd, ONLY: strace
1032 #endif
1033  !
1034  IMPLICIT NONE
1035  !/
1036  !/ ------------------------------------------------------------------- /
1037  !/ Parameter list
1038  !/
1039  INTEGER, INTENT(IN) :: NDS, MX, NX, NY
1040  REAL, INTENT(IN) :: A(MX,NY)
1041  CHARACTER, INTENT(IN) :: MNAME*(*)
1042  !/
1043  !/ ------------------------------------------------------------------- /
1044  !/ Local parameters
1045  !/
1046  INTEGER :: LBLOK, NBLOK, IBLOK, IX, IX1, IX2, IY
1047 #ifdef W3_S
1048  INTEGER, SAVE :: IENT = 0
1049 #endif
1050  !/
1051  !/ ------------------------------------------------------------------- /
1052  !/
1053 #ifdef W3_S
1054  CALL strace (ient, 'OUTMAT')
1055 #endif
1056  !
1057  WRITE(nds,8000) mname
1058  !
1059  ! ------ 80 COLUMNS -----
1060  !
1061  IF(icol.EQ.80) THEN
1062  lblok = 6
1063  nblok = (nx-1)/lblok + 1
1064  DO iblok = 1,nblok
1065  ix1 = (iblok-1)*lblok + 1
1066  ix2 = ix1 + lblok - 1
1067  IF(ix2.GT.nx) ix2 = nx
1068  WRITE(nds,8001) (ix,ix = ix1,ix2)
1069  WRITE(nds,8002)
1070  DO iy = 1,ny
1071  WRITE(nds,8003) iy,(a(ix,iy),ix = ix1,ix2)
1072  END DO
1073  WRITE(nds,8002)
1074  END DO
1075  ELSE
1076  !
1077  ! ---- 132 COLUMNS ----
1078  !
1079  lblok = 12
1080  nblok = (nx-1)/lblok + 1
1081  DO iblok = 1,nblok
1082  ix1 = (iblok-1)*lblok + 1
1083  ix2 = ix1 + lblok - 1
1084  IF(ix2.GT.nx) ix2 = nx
1085  WRITE(nds,9001) (ix,ix = ix1,ix2)
1086  WRITE(nds,9002)
1087  DO iy = 1,ny
1088  WRITE(nds,9003) iy,(a(ix,iy),ix = ix1,ix2)
1089  END DO
1090  WRITE(nds,9002)
1091  END DO
1092  END IF
1093  !
1094  RETURN
1095  !
1096  ! Formats
1097  !
1098 8000 FORMAT(/,1x,' M A T R I X D U M P (REAL) / NAME: ',a)
1099 8001 FORMAT(9x,6i10)
1100 8002 FORMAT(1x,6x,'+',62('-'),'+')
1101 8003 FORMAT(1x,t71,'|',t2,i5,' | ',12e10.3)
1102 9001 FORMAT(9x,12i10)
1103 9002 FORMAT(1x,6x,'+',122('-'),'+')
1104 9003 FORMAT(1x,t131,'|',t2,i5,' | ',12e10.3)
1105  !/
1106  !/ End of OUTMAT ----------------------------------------------------- /
1107  !/
1108  END SUBROUTINE outmat
1109  !/ ------------------------------------------------------------------- /
1110  SUBROUTINE prtblk (NDS, NX, NY, MX, F, MAP, MAP0, FSC, &
1111  IX1, IX2, IX3, IY1, IY2, IY3, PRVAR, PRUNIT)
1112  !/
1113  !/ +-----------------------------------+
1114  !/ | WAVEWATCH III NOAA/NCEP |
1115  !/ | H. L. Tolman |
1116  !/ | FORTRAN 90 |
1117  !/ | Last update : 29-Nov-1999 |
1118  !/ +-----------------------------------+
1119  !/
1120  !/ 04-Jun-1996 : Final FORTRAN 77 ( version 1.18 )
1121  !/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 )
1122  !/
1123  ! 1. Purpose :
1124  !
1125  ! Print a block-type table of a two-dimensional field using a
1126  ! land-sea array.
1127  !
1128  ! 3. Parameters :
1129  !
1130  ! Parameter list
1131  ! ----------------------------------------------------------------
1132  ! NDS Int. I File unit number.
1133  ! NX, NY Int. I X and Y range of arrays.
1134  ! MY Int. I Actual X size of arrays.
1135  ! F R.A. I Array to pr presented.
1136  ! MAP I.A. I Map array for land points.
1137  ! MAP0 Int. I Map value for land points in MAP.
1138  ! FSC Real I Scaling factor.
1139  ! IX1-3 Int. I Firts, last, increment grid points in X
1140  ! direction.
1141  ! IY1-3 Int. I Id. Y direction.
1142  ! PRVAR C*(*) I Name of variable.
1143  ! PRUNIT C*(*) I Units of spectrum.
1144  ! ----------------------------------------------------------------
1145  !
1146  ! 4. Subroutines used :
1147  !
1148  ! See mudule documentation.
1149  !
1150  ! 5. Called by :
1151  !
1152  ! Any program.
1153  !
1154  ! 6. Error messages :
1155  !
1156  ! None.
1157  !
1158  ! 7. Remarks :
1159  !
1160  ! 8. Structure :
1161  !
1162  ! ------------------------------------------------
1163  ! Check if automatic scaling
1164  ! If automatic scaling : get extermata
1165  ! Print heading
1166  ! Print table
1167  ! Print ending
1168  ! ------------------------------------------------
1169  !
1170  ! 9. Switches :
1171  !
1172  ! !/S Enable subroutine tracing using STRACE.
1173  !
1174  ! 10. Source code :
1175  !
1176  !/ ------------------------------------------------------------------- /
1177  !/
1178 #ifdef W3_S
1179  USE w3servmd, ONLY: strace
1180 #endif
1181  !
1182  IMPLICIT NONE
1183  !/
1184  !/ ------------------------------------------------------------------- /
1185  !/ Parameter list
1186  !/
1187  INTEGER, INTENT(IN) :: NDS, NX, NY, MX, MAP(MX,NY), MAP0, &
1188  IX1, IX2, IX3, IY1, IY2, IY3
1189  REAL, INTENT(IN) :: F(MX,NY), FSC
1190  CHARACTER, INTENT(IN) :: PRVAR*(*), PRUNIT*(*)
1191  !/
1192  !/ ------------------------------------------------------------------- /
1193  !/ Local parameters
1194  !/
1195  INTEGER :: IX, IY, JJ, JM, K1, LX, I
1196 #ifdef W3_S
1197  INTEGER, SAVE :: IENT = 0
1198 #endif
1199  REAL :: FMAX, RR
1200  LOGICAL :: FLSCLE
1201  CHARACTER :: PNUM*5, STRA*5, PNUM2*2, STRA3*3
1202  dimension :: pnum(25), pnum2(61)
1203  !/
1204  !/ ------------------------------------------------------------------- /
1205  !/
1206 #ifdef W3_S
1207  CALL strace (ient, 'PRTBLK')
1208 #endif
1209  !
1210  ! Check scaling
1211  !
1212  flscle = (fsc.LE.0.)
1213  !
1214  ! Extremata
1215  !
1216  IF (flscle) THEN
1217  fmax = 1.e-15
1218  DO ix=1, nx
1219  DO iy=1, ny
1220  IF ( map(ix,iy) .NE. map0 ) &
1221  fmax = max( fmax , abs(f(ix,iy)) )
1222  END DO
1223  END DO
1224  END IF
1225  !
1226  ! Normalized print plot -----------------------------------------------
1227  !
1228  IF (flscle) THEN
1229  !
1230  ! Heading
1231  !
1232  WRITE (nds,901) prvar, fmax, prunit
1233  !
1234  stra = ' '
1235  jj = 0
1236  DO ix = ix1, ix2, ix3
1237  jj = jj + 1
1238  END DO
1239  lx = jj
1240  WRITE (nds,911)
1241  WRITE (nds,912) (ix,ix=ix1,ix2,2*ix3)
1242  pnum2(1) = '--'
1243  WRITE (nds,910) stra, ' +', (pnum2(1), i=1, lx), '-+'
1244  !
1245  ! Write table
1246  !
1247  jm = 0
1248  DO iy = iy2, iy1, iy3*(-1)
1249  !
1250  jj = 0
1251  DO ix = ix1, ix2, ix3
1252  jj = jj + 1
1253  IF (map(ix,iy).EQ.map0) THEN
1254  pnum2(jj) = ' '
1255  ELSE
1256  rr = 10.*f(ix,iy)/fmax
1257  WRITE (stra, fmt='(I2,3X)') int(rr*1.000001)
1258  pnum2(jj) = stra(1:2)
1259  IF (pnum2(jj).EQ.'10' .OR. pnum2(jj).EQ.'**' .OR. &
1260  f(ix,iy).EQ.fmax) THEN
1261  IF ( rr .LT. 0. ) THEN
1262  pnum2(jj) = '-*'
1263  ELSE
1264  pnum2(jj) = ' *'
1265  END IF
1266  END IF
1267  END IF
1268  END DO
1269  !
1270  IF (jm.EQ.0) THEN
1271  WRITE (stra, fmt='(I5)') iy
1272  jm = 2
1273  ELSE
1274  stra = ' '
1275  jm = jm-1
1276  END IF
1277  !
1278  lx = jj
1279  WRITE (nds,910) stra, ' |', (pnum2(i), i=1, lx), ' |'
1280  END DO
1281  !
1282  stra = ' '
1283  pnum2(1) = '--'
1284  WRITE (nds,910) stra, ' +', (pnum2(1), i=1, lx), '-+'
1285  WRITE (nds,912) (ix,ix=ix1,ix2,2*ix3)
1286  WRITE (nds,911)
1287  !
1288  ! Non-normalized print plot -------------------------------------------
1289  !
1290  ELSE
1291  !
1292  ! Heading
1293  !
1294  WRITE (nds,900) prvar, fsc, prunit
1295  !
1296  jj = 0
1297  pnum(1) = ' '
1298  DO ix = ix1, ix2, ix3
1299  jj = jj + 1
1300  END DO
1301  lx = jj
1302  WRITE (nds,921)
1303  WRITE (nds,922) (ix,ix=ix1,ix2,ix3)
1304  stra3 = ' '
1305  pnum(1) = '-----'
1306  WRITE (nds,920) stra3, ' +', (pnum(1), i=1, lx), '-+ '
1307  !
1308  ! Write table
1309  !
1310  jm = 0
1311  DO iy = iy2, iy1, iy3*(-1)
1312  IF (jm.EQ.0) THEN
1313  WRITE (stra3, fmt='(I3)') iy
1314  jm = 2
1315  ELSE
1316  stra3 = ' '
1317  jm = jm-1
1318  END IF
1319  !
1320  jj = 0
1321  DO ix = ix1, ix2, ix3
1322  jj = jj + 1
1323  IF (map(ix,iy).EQ.map0) THEN
1324  pnum(jj) = ' '
1325  ELSE
1326  rr = f(ix,iy)
1327  k1 = nint(rr / fsc)
1328  WRITE (stra, fmt='(I5)') k1
1329  pnum(jj) = stra
1330  END IF
1331  END DO
1332  !
1333  lx = jj
1334  WRITE (nds,920) stra3, ' |', (pnum(i), i=1, lx), ' | '
1335  END DO
1336  !
1337  stra3 = ' '
1338  pnum(1) = '-----'
1339  WRITE (nds,920) stra3, ' +', (pnum(1), i=1, lx), '-+ '
1340  WRITE (nds,922) (ix,ix=ix1,ix2,ix3)
1341  WRITE (nds,921)
1342  !
1343  END IF
1344  !
1345  RETURN
1346  !
1347  ! Formats
1348  !
1349 900 FORMAT (/, ' Variable: ',a,' Units: ',e10.3,1x,a)
1350 901 FORMAT (/, ' Variable: ',a,' Max.: ',e10.3,1x,a)
1351  !
1352 910 FORMAT (1x,a5,63a2)
1353 911 FORMAT (' ')
1354 912 FORMAT (6x,32i8)
1355  !
1356 920 FORMAT (1x,a3,a2,25a5)
1357 921 FORMAT (' ')
1358 922 FORMAT (6x,25i5)
1359  !/
1360  !/ End of PRTBLK ----------------------------------------------------- /
1361  !/
1362  END SUBROUTINE prtblk
1363  !/ ------------------------------------------------------------------- /
1364  SUBROUTINE prt1ds (NDS, NFR, E, FR, UFR, NLINES, FTOPI, &
1365  PRVAR, PRUNIT, PNTNME)
1366  !/
1367  !/ +-----------------------------------+
1368  !/ | WAVEWATCH III NOAA/NCEP |
1369  !/ | H. L. Tolman |
1370  !/ | FORTRAN 90 |
1371  !/ | Last update : 29-Nov-1999 |
1372  !/ +-----------------------------------+
1373  !/
1374  !/ 10-Mar-1992 : Final FORTRAN 77 ( version 1.18 )
1375  !/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 )
1376  !/
1377  ! 1. Purpose :
1378  !
1379  ! Produces a print plot of a 1-D spectrum.
1380  !
1381  ! 3. Parameters :
1382  !
1383  ! Parameter list
1384  ! ----------------------------------------------------------------
1385  ! NDS Int. I File unit number.
1386  ! NFR Int. I Number of frequencies.
1387  ! E R.A. I Spectral densities.
1388  ! FR R.A. I Frequencies.
1389  ! UFR C*(*) I If 'HZ', frequencies in Hz, otherwise in
1390  ! rad/s (N.B., does not re-scale spectrum).
1391  ! NLINES Int. I Hight of plot in lines.
1392  ! FTOPI Real I Highest value of density in plot,
1393  ! if FTOPI.LE.0., automatic scaling.
1394  ! PRVAR C*(*) I Name of variable.
1395  ! PRUNIT C*(*) I Units of spectrum.
1396  ! PNTNME C*(*) I Name of location.
1397  ! ----------------------------------------------------------------
1398  !
1399  ! 4. Subroutines used :
1400  !
1401  ! See mudule documentation.
1402  !
1403  ! 5. Called by :
1404  !
1405  ! Any routine.
1406  !
1407  ! 6. Error messages :
1408  !
1409  ! None.
1410  !
1411  ! 7. Remarks :
1412  !
1413  ! - Paperwidth is "set" by NFRMAX.
1414  !
1415  ! 8. Structure :
1416  !
1417  ! ------------------------------------------------
1418  ! Initializations and preparations.
1419  ! Determine maximum of spectra.
1420  ! Scaling / normalization.
1421  ! Printing of spectrum
1422  ! ----------------------------------------------
1423  ! Print ID
1424  ! Print heading
1425  ! Print table
1426  ! Print ending
1427  ! ------------------------------------------------
1428  !
1429  ! 9. Switches :
1430  !
1431  ! !/S Enable subroutine tracing using STRACE.
1432  !
1433  ! 10. Source code :
1434  !
1435  !/ ------------------------------------------------------------------- /
1436  !/
1437 #ifdef W3_S
1438  USE w3servmd, ONLY: strace
1439 #endif
1440  !
1441  IMPLICIT NONE
1442  !/
1443  !/ ------------------------------------------------------------------- /
1444  !/ Parameter list
1445  !/
1446  INTEGER, INTENT(IN) :: NDS, NFR, NLINES
1447  REAL, INTENT(IN) :: FTOPI, E(NFR), FR(NFR)
1448  CHARACTER, INTENT(IN) :: PRVAR*(*), PRUNIT*(*), PNTNME*(*), &
1449  UFR*(*)
1450  !/
1451  !/ ------------------------------------------------------------------- /
1452  !/ Local parameters
1453  !/
1454  INTEGER :: NFRB, IFR, IL, IL0
1455 #ifdef W3_S
1456  INTEGER, SAVE :: IENT = 0
1457 #endif
1458  REAL, SAVE :: TOPFAC = 1.1
1459  REAL :: FTOP, RLINES, FACFR, FSC, FLINE, &
1460  EMAX, EMIN, EXTR, FLOC
1461  LOGICAL :: FLSCLE
1462  CHARACTER :: STRA*10, STRA2*2, PNUM2*2
1463  dimension :: pnum2(nfm2)
1464  !/
1465  !/ ------------------------------------------------------------------- /
1466  !/
1467 #ifdef W3_S
1468  CALL strace (ient, 'PRT1DS')
1469 #endif
1470  !
1471  ftop = ftopi
1472  !
1473  nfrb = min(nfr,50)
1474  rlines = real(nlines)
1475  flscle = ftop.LE.0.
1476  !
1477  IF (ufr.EQ.'HZ') THEN
1478  facfr = 1.
1479  ELSE
1480  facfr = 0.159155
1481  END IF
1482  !
1483  ! Maximum of 1-D spectrum
1484  !
1485  emax = 0.
1486  emin = 0.
1487  !
1488  DO ifr=1, nfr
1489  emax = max( emax , e(ifr) )
1490  emin = min( emin , e(ifr) )
1491  END DO
1492  !
1493  IF (emax.EQ.0. .AND. emin.EQ.0.) THEN
1494  emax = 1.e-20
1495  emin = -1.e-20
1496  END IF
1497  !
1498  IF (emax.GT.abs(emin)) THEN
1499  extr = emax
1500  ELSE
1501  extr = emin
1502  END IF
1503  !
1504  ! Scaling / Normalization
1505  !
1506  IF (flscle) THEN
1507  IF (emax.GT.abs(emin)) THEN
1508  floc = emax * topfac
1509  fsc = floc / real(nint(emax/(emax-emin)*rlines))
1510  ELSE
1511  floc = emin * topfac
1512  fsc = floc / real(nint(emin/(emax-emin)*rlines))
1513  floc = ftop + rlines*fsc
1514  IF (emax.LT.0.01*fsc) ftop = 0.
1515  END IF
1516  ELSE
1517  floc = ftop
1518  fsc = floc / rlines
1519  IF (emax*emin.LT.0) fsc = 2.*fsc
1520  IF (emax.LT.0.01*fsc) floc = 0.
1521  END IF
1522  !
1523  il0 = mod( nint(floc/fsc) , 2 ) + 1
1524  !
1525  ! Print ID
1526  !
1527  WRITE (nds,900) pntnme, prvar, extr, prunit
1528  !
1529  ! Print heading
1530  !
1531  fline = floc
1532  IF (mod(nlines+il0,2).EQ.0) THEN
1533  WRITE (stra, fmt='(E10.3)') fline
1534  ELSE
1535  stra= ' '
1536  END IF
1537  !
1538  DO ifr=1, nfrb
1539  IF ( nint( (e(ifr)-fline)/fsc ) .EQ.0) THEN
1540  pnum2(ifr) = '-*'
1541  ELSE
1542  pnum2(ifr) = '--'
1543  END IF
1544  END DO
1545  !
1546  pnum2(nfrb+1) = '-+'
1547  stra2 = ' +'
1548  WRITE (nds,910) stra, stra2, (pnum2(ifr),ifr=1, nfrb+1)
1549  !
1550  ! Print table
1551  !
1552  DO il = 1, nlines-1
1553  fline = floc - fsc * real(il)
1554  IF (abs(fline).LT.0.01*fsc) fline = 0.
1555  IF (mod(nlines+il0-il,2).EQ.0) THEN
1556  WRITE (stra, fmt='(E10.3)') fline
1557  stra2 = ' +'
1558  ELSE
1559  stra = ' '
1560  stra2 = ' |'
1561  END IF
1562  DO ifr=1, nfrb
1563  IF (abs(fline).LT.0.1*fsc) THEN
1564  pnum2(nfrb+1) = '-|'
1565  IF ( nint( (e(ifr)-fline)/fsc ) .EQ.0) THEN
1566  pnum2(ifr) = '-*'
1567  ELSE
1568  pnum2(ifr) = '--'
1569  END IF
1570  ELSE
1571  pnum2(nfrb+1) = ' |'
1572  IF ( nint( (e(ifr)-fline)/fsc ) .EQ.0) THEN
1573  pnum2(ifr) = ' *'
1574  ELSE
1575  pnum2(ifr) = ' '
1576  END IF
1577  END IF
1578  END DO
1579  WRITE (nds,910) stra, stra2, (pnum2(ifr),ifr=1, nfrb+1)
1580  END DO
1581  !
1582  ! write ending
1583  !
1584  fline = floc - fsc * real(il)
1585  IF (abs(fline).LT.0.01*fsc) fline = 0.
1586  WRITE (stra, fmt='(E10.3)') fline
1587  IF (mod(il0,2).EQ.0) THEN
1588  WRITE (stra, fmt='(E10.3)') fline
1589  ELSE
1590  stra = ' '
1591  END IF
1592  stra2 = ' +'
1593  pnum2(nfrb+1) = '-+'
1594  !
1595  DO ifr=1, nfrb
1596  IF ( nint( (e(ifr)-fline)/fsc ) .EQ.0) THEN
1597  pnum2(ifr) = '-*'
1598  ELSE IF ( mod(ifr-2,4) .EQ. 0 ) THEN
1599  pnum2(ifr) = '-|'
1600  ELSE
1601  pnum2(ifr) = '--'
1602  END IF
1603  END DO
1604  !
1605  WRITE (nds,910) stra, stra2, (pnum2(ifr),ifr=1, nfrb+1)
1606  WRITE (nds,911) (fr(ifr)*facfr,ifr=2,nfrb,4)
1607  WRITE (nds,920)
1608  !
1609  RETURN
1610  !
1611  ! Formats
1612  !
1613 900 FORMAT (/' Location : ',a &
1614  /' Spectrum : ',a,' Extreme value : ',e10.3,1x,a/)
1615  !
1616 910 FORMAT (a10,a2,60a2)
1617 911 FORMAT (10x,15f8.3)
1618  !
1619 920 FORMAT (' ')
1620  !/
1621  !/ End of PRT1DS ----------------------------------------------------- /
1622  !/
1623  END SUBROUTINE prt1ds
1624  !/ ------------------------------------------------------------------- /
1625  SUBROUTINE prt1dm (NDS, NFR, NE, E, FR, UFR, NLINES, FTOPI, &
1626  PRVAR, PRUNIT, PNTNME)
1627  !/
1628  !/ +-----------------------------------+
1629  !/ | WAVEWATCH III NOAA/NCEP |
1630  !/ | H. L. Tolman |
1631  !/ | FORTRAN 90 |
1632  !/ | Last update : 17-Apr-1992 |
1633  !/ +-----------------------------------+
1634  !/
1635  !/ 17-Apr-1992 : Final FORTRAN 77 ( version 1.18 )
1636  !/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 )
1637  !/
1638  ! 1. Purpose :
1639  !
1640  ! Produces a print plot of several 1-D spectra.
1641  !
1642  ! 3. Parameters :
1643  !
1644  ! Parameter list
1645  ! ----------------------------------------------------------------
1646  ! NDS Int. I File unit number.
1647  ! NFR Int. I Number of frequencies.
1648  ! NE Int. I Number of spectra.
1649  ! E R.A. I Spectral densities.
1650  ! FR R.A. I Frequencies.
1651  ! UFR C* I If 'HZ', frequencies in Hz, otherwise in
1652  ! rad/s
1653  ! NLINES Int. I Hight of plot in lines.
1654  ! FTOPI Real I Highest value of density in plot,
1655  ! if FTOP.LE.0., automatic scaling.
1656  ! PRVAR C*(*) I Name of variable.
1657  ! PRUNIT C*(*) I Units of spectrum.
1658  ! PNTNME C*(*) I Name of location.
1659  ! ----------------------------------------------------------------
1660  !
1661  ! 4. Subroutines used :
1662  !
1663  ! See mudule documentation.
1664  !
1665  ! 5. Called by :
1666  !
1667  ! Any routine.
1668  !
1669  ! 6. Error messages :
1670  !
1671  ! None.
1672  !
1673  ! 7. Remarks :
1674  !
1675  ! - Paperwidth is "set" by NFRMAX.
1676  !
1677  ! 8. Structure :
1678  !
1679  ! ------------------------------------------------
1680  ! Initializations and preparations.
1681  ! Determine maximum of spectrum.
1682  ! Scaling / normalization.
1683  ! Printing of spectrum
1684  ! ----------------------------------------------
1685  ! Print ID
1686  ! Print heading
1687  ! Print table
1688  ! Print ending
1689  ! ------------------------------------------------
1690  !
1691  ! 9. Switches :
1692  !
1693  ! !/S Enable subroutine tracing using STRACE.
1694  !
1695  ! 10. Source code :
1696  !
1697  !/ ------------------------------------------------------------------- /
1698  !/
1699 #ifdef W3_S
1700  USE w3servmd, ONLY: strace
1701 #endif
1702  !
1703  IMPLICIT NONE
1704  !/
1705  !/ ------------------------------------------------------------------- /
1706  !/ Parameter list
1707  !/
1708  INTEGER, INTENT(IN) :: NDS, NFR, NE, NLINES
1709  REAL, INTENT(IN) :: FTOPI, E(NFR,NE), FR(NFR)
1710  CHARACTER, INTENT(IN) :: PRVAR*(*), PRUNIT*(*), PNTNME*(*), &
1711  UFR*(*)
1712  dimension :: prvar(ne)
1713  !/
1714  !/ ------------------------------------------------------------------- /
1715  !/ Local parameters
1716  !/
1717  INTEGER, PARAMETER :: NFRMAX = 100
1718  INTEGER, PARAMETER :: NFM2 = nfrmax+1
1719  INTEGER :: NFRB, IFR, IE, IL
1720 #ifdef W3_S
1721  INTEGER, SAVE :: IENT = 0
1722 #endif
1723  REAL, SAVE :: TOPFAC = 1.1
1724  REAL :: FTOP, RLINES, FACFR, FSC, FLINE, &
1725  EMAX, EMIN, EXTR, FLOC
1726  LOGICAL :: FLSCLE
1727  CHARACTER :: STRA*10, STRA2*2, STRAX*2, PNUM2*2
1728  dimension :: pnum2(nfm2)
1729  !/
1730  !/ ------------------------------------------------------------------- /
1731  !/
1732 #ifdef W3_S
1733  CALL strace (ient, 'PRT1DM')
1734 #endif
1735  !
1736  ! Test output, echo input
1737  !
1738 #ifdef W3_T
1739  WRITE (*,*)
1740  WRITE (*,*) 'TEST OUTPUT PRT1DM, ECHO OF INPUT'
1741  WRITE (*,*) '=======================================', &
1742  '======================================='
1743  WRITE (*,*) 'File unit number : ', nds
1744  WRITE (*,*) 'Number of frequencies : ', nfr
1745  WRITE (*,*) 'Number of spectra : ', ne
1746  DO ie=1, ne
1747  WRITE (*,*) 'Spectral densities spectrum ', ie
1748  WRITE (*,'(6X,8E9.2)') (e(ifr,ie),ifr=1,nfr)
1749  END DO
1750  WRITE (*,*) 'Frequencies'
1751  WRITE (*,'(6X,8E9.2)') (fr(ifr),ifr=1,nfr)
1752  WRITE (*,*) 'Frequency type : ', ufr
1753  WRITE (*,*) 'NLINES : ', nlines
1754  WRITE (*,*) 'FTOPI : ', ftopi
1755  WRITE (*,*) 'Names of spectra : ', prvar(1)
1756  DO ie=2, ne
1757  WRITE (*,*) ' ', prvar(ie)
1758  END DO
1759  WRITE (*,*) 'Units of spectra : ', prunit
1760  WRITE (*,*) 'Name of location : ', pntnme
1761  WRITE (*,*) '=======================================', &
1762  '======================================='
1763  WRITE (*,*)
1764 #endif
1765  !
1766  ftop = ftopi
1767  nfrb = min(nfr,50)
1768  rlines = real(nlines)
1769  flscle = ftop.LE.0.
1770  !
1771  IF (ufr.EQ.'HZ') THEN
1772  facfr = 1.
1773  ELSE
1774  facfr = 0.159155
1775  END IF
1776  !
1777  ! Maximum of 1-D spectrum
1778  !
1779  emax = 0.
1780  emin = 0.
1781  !
1782  DO ie=1, ne
1783  DO ifr=1, nfr
1784  emax = max( emax , e(ifr,ie) )
1785  emin = min( emin , e(ifr,ie) )
1786  END DO
1787  END DO
1788  !
1789  IF (emax.EQ.0. .AND. emin.EQ.0.) THEN
1790  emax = 1.e-20
1791  emin = -1.e-20
1792  END IF
1793  !
1794  IF (emax.GT.abs(emin)) THEN
1795  extr = emax
1796  ELSE
1797  extr = emin
1798  END IF
1799  !
1800  ! Scaling / Normalization
1801  !
1802  IF (flscle) THEN
1803  IF (emax.GT.abs(emin)) THEN
1804  ftop = emax * topfac
1805  fsc = ftop / real(nint(emax/(emax-emin)*rlines))
1806  ELSE
1807  ftop = emin * topfac
1808  fsc = ftop / real(nint(emin/(emax-emin)*rlines))
1809  ftop = ftop + rlines*fsc
1810  IF (abs(ftop).LT.0.01*fsc) ftop = 0.
1811  END IF
1812  ELSE
1813  fsc = ftop / rlines
1814  IF (emax*emin.LT.0) fsc = 2.*fsc
1815  IF (emax.EQ.0.) ftop = 0.
1816  END IF
1817  !
1818  ! Print ID
1819  !
1820  WRITE (nds,900) pntnme, extr, prunit
1821  !
1822  ! Print heading
1823  !
1824  fline = ftop
1825  IF (mod(nlines,2).EQ.0) THEN
1826  WRITE (stra, fmt='(E10.3)') fline
1827  ELSE
1828  stra= ' '
1829  END IF
1830  !
1831  DO ifr=1, nfrb
1832  pnum2(ifr) = '--'
1833  DO ie=1, ne
1834  IF ( nint( (e(ifr,ie)-fline)/fsc ) .EQ.0) THEN
1835  IF (ie.LT.10) THEN
1836  WRITE (strax,'(A1,I1)') '-', ie
1837  ELSE
1838  WRITE (strax,'(I2)') ie
1839  END IF
1840  pnum2(ifr) = strax
1841  END IF
1842  END DO
1843  END DO
1844  !
1845  pnum2(nfrb+1) = '-+'
1846  stra2 = ' +'
1847  WRITE (nds,910) stra, stra2, (pnum2(ifr),ifr=1, nfrb+1)
1848  !
1849  ! Print table
1850  !
1851  pnum2(nfrb+1) = ' |'
1852  !
1853  DO il = 1, nlines-1
1854  fline = ftop - fsc * real(il)
1855  IF (abs(fline).LT.0.01*fsc) fline = 0.
1856  IF (mod(nlines-il,2).EQ.0) THEN
1857  WRITE (stra, fmt='(E10.3)') fline
1858  stra2 = ' +'
1859  ELSE
1860  stra = ' '
1861  stra2 = ' |'
1862  END IF
1863  DO ifr=1, nfrb
1864  pnum2(nfrb+1) = ' |'
1865  IF (abs(fline).LT.0.1*fsc) THEN
1866  pnum2(ifr) = '--'
1867  pnum2(nfrb+1) = '-+'
1868  DO ie=1, ne
1869  IF ( nint( (e(ifr,ie)-fline)/fsc ) .EQ.0) THEN
1870  IF (ie.LT.10) THEN
1871  WRITE (strax,'(A1,I1)') '-', ie
1872  ELSE
1873  WRITE (strax,'(I2)') ie
1874  END IF
1875  pnum2(ifr) = strax
1876  END IF
1877  END DO
1878  ELSE
1879  pnum2(ifr) = ' '
1880  DO ie=1, ne
1881  IF ( nint( (e(ifr,ie)-fline)/fsc ) .EQ.0) THEN
1882  WRITE (strax,'(I2)') ie
1883  pnum2(ifr) = strax
1884  END IF
1885  END DO
1886  END IF
1887  END DO
1888  WRITE (nds,910) stra, stra2, (pnum2(ifr),ifr=1, nfrb+1)
1889  END DO
1890  !
1891  ! write ending
1892  !
1893  fline = ftop - fsc * real(il)
1894  IF (abs(fline).LT.0.01*fsc) fline = 0.
1895  WRITE (stra, fmt='(E10.3)') fline
1896  stra2 = ' +'
1897  pnum2(nfrb+1) = '-+'
1898  !
1899  DO ifr=1, nfrb
1900  IF ( mod(ifr-2,4) .EQ. 0 ) THEN
1901  pnum2(ifr) = '-|'
1902  ELSE
1903  pnum2(ifr) = '--'
1904  END IF
1905  DO ie=1, ne
1906  IF ( nint( (e(ifr,ie)-fline)/fsc ) .EQ.0) THEN
1907  IF (ie.LT.10) THEN
1908  WRITE (strax,'(A1,I1)') '-', ie
1909  ELSE
1910  WRITE (strax,'(I2)') ie
1911  END IF
1912  pnum2(ifr) = strax
1913  END IF
1914  END DO
1915  END DO
1916  !
1917  WRITE (nds,910) stra, stra2, (pnum2(ifr),ifr=1, nfrb+1)
1918  WRITE (nds,911) (fr(ifr)*facfr,ifr=2,nfrb,4)
1919  WRITE (nds,920)
1920  WRITE (nds,921) (prvar(ie),ie=1,ne)
1921  WRITE (nds,920)
1922  IF (flscle) ftop = 0.
1923  !
1924  RETURN
1925  !
1926  ! Formats
1927  !
1928 900 FORMAT (/' Location : ',a &
1929  /' Extreme value : ',e10.3,1x,a/)
1930  !
1931 910 FORMAT (a10,a2,60a2)
1932 911 FORMAT (10x,15f8.3)
1933  !
1934 920 FORMAT (' ')
1935 921 FORMAT (10x,'spectra : ',10(a,' ')/)
1936  !/
1937  !/ End of PRT1DM ----------------------------------------------------- /
1938  !/
1939  END SUBROUTINE prt1dm
1940  !/ ------------------------------------------------------------------- /
1941  SUBROUTINE prt2ds (NDS, NFR0, NFR, NTH, E, FR, UFR, FACSP, FSC, &
1942  RRCUT, PRVAR, PRUNIT, PNTNME)
1943  !/
1944  !/ +-----------------------------------+
1945  !/ | WAVEWATCH III NOAA/NCEP |
1946  !/ | H. L. Tolman |
1947  !/ | FORTRAN 90 |
1948  !/ | Last update : 29-Nov-1999 |
1949  !/ +-----------------------------------+
1950  !/
1951  !/ 07-Jun-1996 : Final FORTRAN 77 ( version 1.18 )
1952  !/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 )
1953  !/
1954  ! 1. Purpose :
1955  !
1956  ! Prints a block type table of a 2-D spectrum. Input considers
1957  ! cartesian directions, output according to meteorological
1958  ! conventions (compass direction where waves come from).
1959  !
1960  ! 3. Parameters :
1961  !
1962  ! Parameter list
1963  ! ----------------------------------------------------------------
1964  ! NDS Int. I File unit number.
1965  ! NFR0 Int. I Array size for freq.
1966  ! NFR Int. I Number of frequencies.
1967  ! NTH Int. I Number of frequencies.
1968  ! E R.A. I Spectral densities.
1969  ! FR R.A. I Frequencies.
1970  ! UFR C*(*) I If 'HZ', frequencies in Hz, otherwise in
1971  ! rad/s
1972  ! FACSP Real I Conversion factor to obtain (Hz,degr)
1973  ! spectrum from E
1974  ! FSC Real I Scale factor, if FSC.eq.0. automatic
1975  ! scaling for "compressed" block.
1976  ! RRCUT Real I Relative cut-off for printing.
1977  ! PRVAR C*(*) I Name of variable.
1978  ! PRUNIT C*(*) I Units of spectrum.
1979  ! PNTNME C*(*) I Name of location.
1980  ! ----------------------------------------------------------------
1981  !
1982  ! 4. Subroutines used :
1983  !
1984  ! ANGSTR (Internal)
1985  !
1986  ! 5. Called by :
1987  !
1988  ! Any program.
1989  !
1990  ! 6. Error messages :
1991  !
1992  ! None.
1993  !
1994  ! 7. Remarks :
1995  !
1996  ! PNUM2: dimensioning changed from 51 to 71 due to "subscript out
1997  ! of range" fault (Sep 28 2012)
1998  !
1999  ! 8. Structure :
2000  !
2001  ! ------------------------------------------------
2002  ! Initializations and preparations.
2003  ! Determine maximum of spectrum.
2004  ! Scaling / normalization.
2005  ! Do for normalized or non-norm. spectrum
2006  ! ----------------------------------------------
2007  ! Print ID
2008  ! Print heading
2009  ! Print table
2010  ! Print ending
2011  ! ------------------------------------------------
2012  !
2013  ! 9. Switches :
2014  !
2015  ! !/S Enable subroutine tracing using STRACE.
2016  ! !/T Diagnostic test output.
2017  !
2018  ! 10. Source code :
2019  !
2020  !/ ------------------------------------------------------------------- /
2021  !/
2022 #ifdef W3_S
2023  USE w3servmd, ONLY: strace
2024 #endif
2025  !
2026  IMPLICIT NONE
2027  !/
2028  !/ ------------------------------------------------------------------- /
2029  !/ Parameter list
2030  !/
2031  INTEGER, INTENT(IN) :: NDS, NFR0, NFR, NTH
2032  REAL, INTENT(IN) :: E(NFR0,*), FR(*), FACSP, FSC, RRCUT
2033  CHARACTER, INTENT(IN) :: PRVAR*(*), PRUNIT*(*), PNTNME*(*), &
2034  UFR*(*)
2035  !/
2036  !/ ------------------------------------------------------------------- /
2037  !/ Local parameters
2038  !/
2039  INTEGER :: IFR, ITH, NFRB, INTANG, ITHSEC
2040 #ifdef W3_S
2041  INTEGER, SAVE :: IENT = 0
2042 #endif
2043  LOGICAL :: FLSCLE
2044  REAL :: FACFR, EMAX, EMIN, DTHDEG, RR, RRC
2045  CHARACTER :: PNUM*5, STRA*5, STRANG*5, PNUM2*2, &
2046  STRA2*2
2047  dimension :: pnum(25), pnum2(101)
2048  !/
2049  !/ ------------------------------------------------------------------- /
2050  !/
2051 #ifdef W3_S
2052  CALL strace (ient, 'PRT2DS')
2053 #endif
2054  !
2055 #ifdef W3_T
2056  WRITE (nds,9000) nds, nfr0, nfr, nth, ufr, facsp, fsc, &
2057  rrcut, prvar, prunit, pntnme
2058 #endif
2059  !
2060  ! initialisations
2061  !
2062  flscle = .false.
2063  IF (fsc.EQ.0.) THEN
2064  flscle = .true.
2065  rrc = rrcut * 10.
2066  END IF
2067  !
2068  IF (ufr.EQ.'HZ') THEN
2069  facfr = 1.
2070  ELSE
2071  facfr = 0.159155
2072  END IF
2073  !
2074  ! Maximum of spectrum
2075  !
2076  emax = 1.e-20
2077  emin = 0.
2078  !
2079  DO ifr=1, nfr
2080  DO ith=1, nth
2081  emax = max( emax , e(ifr,ith) )
2082  emin = min( emin , e(ifr,ith) )
2083  END DO
2084  END DO
2085  !
2086  emax = max(emax, abs(emin) )
2087  !
2088  dthdeg = 360. / real(nth)
2089  !
2090  ! Normalized spectra : = = = = = = = = = = = = = = = = = = = = = =
2091  !
2092  IF (flscle) THEN
2093  !
2094  ! Write ID
2095  !
2096  WRITE (nds,900) pntnme, prvar, emax*facsp, prunit
2097  !
2098  ! Write Head
2099  !
2100  nfrb = min(nfr,50)
2101  WRITE (nds,910) (fr(ifr)*facfr,ifr=2,nfrb,4)
2102  !
2103  DO ifr=1, nfr
2104  IF ( mod((ifr-2),4) .EQ. 0) THEN
2105  pnum2(ifr) = '-|'
2106  ELSE
2107  pnum2(ifr) = '--'
2108  END IF
2109  END DO
2110  !
2111  pnum2(nfrb+1) = '-+'
2112  WRITE (nds,920) (pnum2(ifr),ifr=1, nfrb+1)
2113  !
2114  ! Write table
2115  !
2116  ithsec = nth + 1
2117  !
2118  DO ith= nth, 1, -1
2119  intang = 270 - nint(dthdeg*real(ith-1))
2120  IF (intang.LT.0) THEN
2121  ithsec = ith
2122  cycle
2123  END IF
2124  CALL angstr (intang, strang, 4, 2)
2125  DO ifr=1, nfrb
2126  rr = e(ifr,ith)/emax
2127  IF (e(ifr,ith).EQ.emax .OR. rr.GE.1.) THEN
2128  pnum2(ifr) = ' *'
2129  ELSE IF (-e(ifr,ith).EQ.emax .OR. rr.LE.-1.) THEN
2130  pnum2(ifr) = ' #'
2131  ELSE IF (abs(rr).LT.rrc) THEN
2132  pnum2(ifr) = ' '
2133  ELSE IF ((rr*10.).LT.0. .AND. (rr*10.).GT.-1.) THEN
2134  pnum2(ifr) = '-0'
2135  ELSE
2136  WRITE (stra2, fmt='(I2)') int(rr*10.)
2137  pnum2(ifr) = stra2
2138  END IF
2139  END DO
2140  pnum2(nfrb+1) = ' |'
2141  WRITE (nds,930) strang, (pnum2(ifr),ifr=1, nfrb+1)
2142  END DO
2143  !
2144  DO ith= nth, ithsec, -1
2145  intang = 630 - nint(dthdeg*real(ith-1))
2146  CALL angstr (intang, strang, 4, 2)
2147  DO ifr=1, nfrb
2148  rr = e(ifr,ith)/emax
2149  IF (e(ifr,ith).EQ.emax .OR. rr.GE.1.) THEN
2150  pnum2(ifr) = ' *'
2151  ELSE IF (-e(ifr,ith).EQ.emax .OR. rr.LE.-1.) THEN
2152  pnum2(ifr) = ' #'
2153  ELSE IF (abs(rr).LT.rrc) THEN
2154  pnum2(ifr) = ' '
2155  ELSE IF ((rr*10.).LT.0. .AND. (rr*10.).GT.-1.) THEN
2156  pnum2(ifr) = '-0'
2157  ELSE
2158  WRITE (stra2, fmt='(I2)') int(rr*10.)
2159  pnum2(ifr) = stra2
2160  END IF
2161  END DO
2162  pnum2(nfrb+1) = ' |'
2163  WRITE (nds,930) strang, (pnum2(ifr),ifr=1, nfrb+1)
2164  END DO
2165  !
2166  ! Write ending:
2167  !
2168  pnum2(1) = '--'
2169  pnum2(2) = '-+'
2170  WRITE (nds,920) (pnum2(1),ifr=1, nfrb), pnum2(2)
2171  WRITE (nds,950)
2172  !
2173  ! Scaled spectra : = = = = = = = = = = = = = = = = = = = = = = = =
2174  !
2175  ELSE
2176  !
2177  ! Write ID
2178  !
2179  WRITE (nds,901) pntnme, prvar, fsc, prunit, &
2180  emax*facsp, prunit
2181  !
2182  ! Write heading
2183  !
2184  nfrb = min(nfr,25)
2185  !
2186  WRITE (nds,911) (fr(ifr)*facfr,ifr=2,nfrb,2)
2187  pnum(1) = '-----'
2188  pnum(2) = '-- '
2189  !
2190  IF (nfrb.LT.25) THEN
2191  WRITE (nds,921) (pnum(1),ifr=1, nfrb), pnum(2)
2192  ELSE
2193  WRITE (nds,921) (pnum(1),ifr=1, nfrb)
2194  END IF
2195  !
2196  ! write table :
2197  !
2198  ithsec = nth + 1
2199  !
2200  DO ith= nth, 1, -1
2201  intang = 270 - nint(dthdeg*real(ith-1))
2202  IF (intang.LT.0) THEN
2203  ithsec = ith
2204  cycle
2205  END IF
2206  CALL angstr (intang, strang, 4, 2)
2207  DO ifr=1, nfrb
2208  rr = e(ifr,ith)
2209  IF (abs(rr/emax).LT.rrcut) THEN
2210  pnum(ifr) = ' '
2211  ELSE
2212  WRITE (stra, fmt='(I5)') nint(rr*facsp/fsc)
2213  pnum(ifr) = stra
2214  END IF
2215  END DO
2216  WRITE (nds,931) strang, (pnum(ifr),ifr=1, nfrb)
2217  END DO
2218  !
2219  DO ith= nth, ithsec, -1
2220  intang = 630 - nint(dthdeg*real(ith-1))
2221  CALL angstr (intang, strang, 4, 2)
2222  DO ifr=1, nfrb
2223  rr = e(ifr,ith)
2224  IF (abs(rr/emax).LT.rrcut) THEN
2225  pnum(ifr) = ' '
2226  ELSE
2227  WRITE (stra, fmt='(I5)') nint(rr*facsp/fsc)
2228  pnum(ifr) = stra
2229  END IF
2230  END DO
2231  WRITE (nds,931) strang, (pnum(ifr),ifr=1, nfrb)
2232  END DO
2233  !
2234  ! write ending :
2235  !
2236  pnum(1) = '-----'
2237  pnum(2) = '-- '
2238  IF (nfrb.LT.25) THEN
2239  WRITE (nds,921) (pnum(1),ifr=1, nfrb), pnum(2)
2240  ELSE
2241  WRITE (nds,921) (pnum(1),ifr=1, nfrb)
2242  END IF
2243  WRITE (nds,950)
2244  !
2245  END IF
2246  !
2247  RETURN
2248  !
2249  ! Formats
2250  !
2251 900 FORMAT (/' Location : ',a/ &
2252  ' Spectrum : ',a,' (Normalized) ', &
2253  ' Maximum value : ',e10.3,1x,a/)
2254 901 FORMAT (/' Location : ',a/ &
2255  ' Spectrum : ',a,' Units : ',e10.3,1x,a, &
2256  ' Maximum value : ',e10.3,1x,a/)
2257  !
2258 910 FORMAT (5x,' ang.| frequencies (Hz) '/ &
2259  5x,' deg.|',f6.3,15f8.3)
2260 920 FORMAT (5x,' ----+',60a2)
2261 930 FORMAT (5x,' ',a4,' |',60a2)
2262  !
2263 911 FORMAT (' ang.| frequencies (Hz) '/ &
2264  ' deg.|',12f10.3)
2265 921 FORMAT (' ----|',25a5)
2266 931 FORMAT (' ',a4,' |',25a5)
2267  !
2268 950 FORMAT (' ')
2269  !
2270 #ifdef W3_T
2271 9000 FORMAT ( ' TEST PRT2DS : ECHO OF INPUT PARAMETERS'/ &
2272  ' NDS :',i6/ &
2273  ' NFR0, NFR :',2i6/ &
2274  ' NTH :',i6/ &
2275  ' UFR : ',a/ &
2276  ' FACSP :',e10.3/ &
2277  ' FSC :',e10.3/ &
2278  ' RRCUT :',e10.3/ &
2279  ' PRVAR : ',a/ &
2280  ' PRUNIT : ',a/ &
2281  ' PNTNME : ',a)
2282 #endif
2283  !/
2284  !/ Internal subroutine ANGSTR ---------------------------------------- /
2285  !/
2286  CONTAINS
2287  !/
2288  !/ ------------------------------------------------------------------- /
2289  SUBROUTINE angstr (IANG, SANG, ILEN, INUM)
2290  !/
2291  !/ +-----------------------------------+
2292  !/ | WAVEWATCH III NOAA/NCEP |
2293  !/ | H. L. Tolman |
2294  !/ | FORTRAN 90 |
2295  !/ | Last update : 29-Nov-1999 |
2296  !/ +-----------------------------------+
2297  !/
2298  !/ 10-Mar-1992 : Final FORTRAN 77 ( version 1.18 )
2299  !/ 29-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 )
2300  !
2301  ! INPUT : IANG --> INTEGER ANGLE (DEGREES)
2302  ! ILEN --> STRING LENGTH
2303  ! INUM --> <1 : ONLY FOUR MAIN DIRECTIONS
2304  ! 1 : N,E,S,W AND NUMERICAL OUTPUT
2305  ! 2 : EIGHT MAIN DIRECTIONS
2306  ! >2 : EIGHT DIRECTIONS + NUMERICAL OUTPUT
2307  ! OUTPUT : SANG --> STRING
2308  !
2309  !/ ------------------------------------------------------------------- /
2310  !/
2311 #ifdef W3_S
2312  USE w3servmd, ONLY: strace
2313 #endif
2314  !
2315  IMPLICIT NONE
2316  !/
2317  !/ ------------------------------------------------------------------- /
2318  !/ Parameter list
2319  !/
2320  INTEGER, INTENT(IN) :: IANG, ILEN, INUM
2321  CHARACTER, INTENT(OUT) :: SANG*(*)
2322  !/
2323  !/ ------------------------------------------------------------------- /
2324  !/ Local parameters
2325  !/
2326  INTEGER :: I, J
2327  CHARACTER :: SAUX*4
2328  !/
2329  !/ ------------------------------------------------------------------- /
2330  !/
2331  ! numerical :
2332  !
2333  IF (inum.EQ.1 .OR. inum.GE.3) THEN
2334  WRITE (saux, fmt='(I4)') iang
2335  ELSE
2336  saux = ' '
2337  END IF
2338  !
2339  ! string :
2340  !
2341  IF (iang.EQ.0) THEN
2342  saux = ' N'
2343  ELSE IF (iang.EQ.90) THEN
2344  saux = ' E'
2345  ELSE IF (iang.EQ.180) THEN
2346  saux = ' S'
2347  ELSE IF (iang.EQ.270) THEN
2348  saux = ' W'
2349  ELSE IF (inum.GE.2) THEN
2350  IF (iang.EQ.45) THEN
2351  saux = ' NE'
2352  ELSE IF (iang.EQ.135) THEN
2353  saux = ' SE'
2354  ELSE IF (iang.EQ.225) THEN
2355  saux = ' SW'
2356  ELSE IF (iang.EQ.315) THEN
2357  saux = ' NW'
2358  END IF
2359  END IF
2360  !
2361  ! Auxilary string to output :
2362  !
2363  DO i=1, ilen-4
2364  sang = ' '
2365  END DO
2366  j = 0
2367  DO i=ilen-3, ilen
2368  j = j + 1
2369  sang(i:i) = saux(j:j)
2370  END DO
2371  RETURN
2372  !/
2373  !/ End of ANGSTR ----------------------------------------------------- /
2374  !/
2375  END SUBROUTINE angstr
2376  !/
2377  !/ End of PRT2DS ----------------------------------------------------- /
2378  !/
2379  END SUBROUTINE prt2ds
2380  !/
2381  !/ End of module W3ARRYMD -------------------------------------------- /
2382  !/
2383 END MODULE w3arrymd
w3arrymd::prt1dm
subroutine prt1dm(NDS, NFR, NE, E, FR, UFR, NLINES, FTOPI, PRVAR, PRUNIT, PNTNME)
Definition: w3arrymd.F90:1627
w3arrymd::outa2i
subroutine outa2i(ARRAY, MX, MY, LX, HX, LY, HY, NDS, NDST, NDSE, IDFM, RFORM, IDLA, VSC, VOF)
Definition: w3arrymd.F90:627
w3arrymd::outa2r
subroutine outa2r(ARRAY, MX, MY, LX, HX, LY, HY, NDS, NDST, NDSE, IDFM, RFORM, IDLA, VSC, VOF)
Definition: w3arrymd.F90:465
w3arrymd::ina2i
subroutine ina2i(ARRAY, MX, MY, LX, HX, LY, HY, NDS, NDST, NDSE, IDFM, RFORM, IDLA, VSC, VOF)
Definition: w3arrymd.F90:295
w3arrymd::outmat
subroutine outmat(NDS, A, MX, NX, NY, MNAME)
Definition: w3arrymd.F90:988
w3arrymd::ina2r
subroutine ina2r(ARRAY, MX, MY, LX, HX, LY, HY, NDS, NDST, NDSE, IDFM, RFORM, IDLA, VSC, VOF)
Definition: w3arrymd.F90:78
w3arrymd::outrea
subroutine outrea(NDS, ARRAY, DIM, ANAME)
Definition: w3arrymd.F90:781
w3servmd
Definition: w3servmd.F90:3
angstr
subroutine angstr(IANG, SANG, ILEN, INUM)
Definition: w3arrymd.F90:2290
w3arrymd::prt1ds
subroutine prt1ds(NDS, NFR, E, FR, UFR, NLINES, FTOPI, PRVAR, PRUNIT, PNTNME)
Definition: w3arrymd.F90:1366
w3servmd::strace
subroutine strace(IENT, SNAME)
Definition: w3servmd.F90:148
w3arrymd
Definition: w3arrymd.F90:3
w3arrymd::outint
subroutine outint(NDS, IARRAY, DIM, ANAME)
Definition: w3arrymd.F90:873
w3servmd::extcde
subroutine extcde(IEXIT, UNIT, MSG, FILE, LINE, COMM)
Definition: w3servmd.F90:736
w3arrymd::prt2ds
subroutine prt2ds(NDS, NFR0, NFR, NTH, E, FR, UFR, FACSP, FSC, RRCUT, PRVAR, PRUNIT, PNTNME)
Definition: w3arrymd.F90:1943
w3arrymd::prtblk
subroutine prtblk(NDS, NX, NY, MX, F, MAP, MAP0, FSC, IX1, IX2, IX3, IY1, IY2, IY3, PRVAR, PRUNIT)
Definition: w3arrymd.F90:1112