WAVEWATCH III  beta 0.0.1
Functions/Subroutines
w3arrymd Module Reference

Functions/Subroutines

subroutine ina2r (ARRAY, MX, MY, LX, HX, LY, HY, NDS, NDST, NDSE, IDFM, RFORM, IDLA, VSC, VOF)
 
subroutine ina2i (ARRAY, MX, MY, LX, HX, LY, HY, NDS, NDST, NDSE, IDFM, RFORM, IDLA, VSC, VOF)
 
subroutine outa2r (ARRAY, MX, MY, LX, HX, LY, HY, NDS, NDST, NDSE, IDFM, RFORM, IDLA, VSC, VOF)
 
subroutine outa2i (ARRAY, MX, MY, LX, HX, LY, HY, NDS, NDST, NDSE, IDFM, RFORM, IDLA, VSC, VOF)
 
subroutine outrea (NDS, ARRAY, DIM, ANAME)
 
subroutine outint (NDS, IARRAY, DIM, ANAME)
 
subroutine outmat (NDS, A, MX, NX, NY, MNAME)
 
subroutine prtblk (NDS, NX, NY, MX, F, MAP, MAP0, FSC, IX1, IX2, IX3, IY1, IY2, IY3, PRVAR, PRUNIT)
 
subroutine prt1ds (NDS, NFR, E, FR, UFR, NLINES, FTOPI, PRVAR, PRUNIT, PNTNME)
 
subroutine prt1dm (NDS, NFR, NE, E, FR, UFR, NLINES, FTOPI, PRVAR, PRUNIT, PNTNME)
 
subroutine prt2ds (NDS, NFR0, NFR, NTH, E, FR, UFR, FACSP, FSC, RRCUT, PRVAR, PRUNIT, PNTNME)
 

Function/Subroutine Documentation

◆ ina2i()

subroutine w3arrymd::ina2i ( integer, dimension(mx,my), intent(out)  ARRAY,
integer, intent(in)  MX,
integer, intent(in)  MY,
integer, intent(in)  LX,
integer, intent(in)  HX,
integer, intent(in)  LY,
integer, intent(in)  HY,
integer, intent(in)  NDS,
integer, intent(in)  NDST,
integer, intent(in)  NDSE,
integer, intent(in)  IDFM,
character, dimension(*), intent(in)  RFORM,
integer, intent(in)  IDLA,
integer, intent(in)  VSC,
integer, intent(in)  VOF 
)

Definition at line 295 of file w3arrymd.F90.

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  !/

References w3servmd::extcde(), and w3servmd::strace().

Referenced by w3prep(), w3prnc(), and w3prtide().

◆ ina2r()

subroutine w3arrymd::ina2r ( real, dimension(mx,my), intent(out)  ARRAY,
integer, intent(in)  MX,
integer, intent(in)  MY,
integer, intent(in)  LX,
integer, intent(in)  HX,
integer, intent(in)  LY,
integer, intent(in)  HY,
integer, intent(in)  NDS,
integer, intent(in)  NDST,
integer, intent(in)  NDSE,
integer, intent(in)  IDFM,
character, dimension(*), intent(in)  RFORM,
integer, intent(in)  IDLA,
real, intent(in)  VSC,
real, intent(in)  VOF 
)

Definition at line 78 of file w3arrymd.F90.

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  !/

References w3servmd::extcde(), and w3servmd::strace().

Referenced by w3prep(), w3prnc(), and w3prtide().

◆ outa2i()

subroutine w3arrymd::outa2i ( integer, dimension(mx,my), intent(in)  ARRAY,
integer, intent(in)  MX,
integer, intent(in)  MY,
integer, intent(in)  LX,
integer, intent(in)  HX,
integer, intent(in)  LY,
integer, intent(in)  HY,
integer, intent(in)  NDS,
integer, intent(in)  NDST,
integer, intent(in)  NDSE,
integer, intent(in)  IDFM,
character, dimension(*), intent(in)  RFORM,
integer, intent(in)  IDLA,
integer, intent(in)  VSC,
integer, intent(in)  VOF 
)

Definition at line 627 of file w3arrymd.F90.

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  !/

References w3servmd::extcde(), and w3servmd::strace().

Referenced by w3exgo(), w3exnc(), and w3gspl().

◆ outa2r()

subroutine w3arrymd::outa2r ( real, dimension(mx,my), intent(in)  ARRAY,
integer, intent(in)  MX,
integer, intent(in)  MY,
integer, intent(in)  LX,
integer, intent(in)  HX,
integer, intent(in)  LY,
integer, intent(in)  HY,
integer, intent(in)  NDS,
integer, intent(in)  NDST,
integer, intent(in)  NDSE,
integer, intent(in)  IDFM,
character, dimension(*), intent(in)  RFORM,
integer, intent(in)  IDLA,
real, intent(in)  VSC,
real, intent(in)  VOF 
)

Definition at line 465 of file w3arrymd.F90.

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  !/

References w3servmd::extcde(), and w3servmd::strace().

Referenced by w3gspl().

◆ outint()

subroutine w3arrymd::outint ( integer, intent(in)  NDS,
integer, dimension(dim), intent(in)  IARRAY,
integer, intent(in)  DIM,
character, dimension(*), intent(in)  ANAME 
)

Definition at line 873 of file w3arrymd.F90.

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  !/

References w3servmd::strace().

◆ outmat()

subroutine w3arrymd::outmat ( integer, intent(in)  NDS,
real, dimension(mx,ny), intent(in)  A,
integer, intent(in)  MX,
integer, intent(in)  NX,
integer, intent(in)  NY,
character, dimension(*), intent(in)  MNAME 
)

Definition at line 988 of file w3arrymd.F90.

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  !/

References w3servmd::strace().

Referenced by w3sbt1md::w3sbt1(), w3sdb1md::w3sdb1(), w3src1md::w3sds1(), w3src2md::w3sds2(), w3src3md::w3sds3(), w3src4md::w3sds4(), w3sic1md::w3sic1(), w3sic2md::w3sic2(), w3sic3md::w3sic3(), w3sic4md::w3sic4(), w3sic5md::w3sic5(), w3src1md::w3sin1(), w3src2md::w3sin2(), w3src3md::w3sin3(), w3src4md::w3sin4(), w3snl1md::w3snl1(), and w3snl2md::w3snl2().

◆ outrea()

subroutine w3arrymd::outrea ( integer, intent(in)  NDS,
real, dimension(dim), intent(in)  ARRAY,
integer, intent(in)  DIM,
character, dimension(*), intent(in)  ANAME 
)

Definition at line 781 of file w3arrymd.F90.

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  !/

References w3servmd::strace().

◆ prt1dm()

subroutine w3arrymd::prt1dm ( integer, intent(in)  NDS,
integer, intent(in)  NFR,
integer, intent(in)  NE,
real, dimension(nfr,ne), intent(in)  E,
real, dimension(nfr), intent(in)  FR,
character, dimension(*), intent(in)  UFR,
integer, intent(in)  NLINES,
real, intent(in)  FTOPI,
character, dimension(ne), intent(in)  PRVAR,
character, dimension(*), intent(in)  PRUNIT,
character, dimension(*), intent(in)  PNTNME 
)

Definition at line 1627 of file w3arrymd.F90.

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  !/

References w3servmd::strace().

Referenced by w3exnc(), and w3expo().

◆ prt1ds()

subroutine w3arrymd::prt1ds ( integer, intent(in)  NDS,
integer, intent(in)  NFR,
real, dimension(nfr), intent(in)  E,
real, dimension(nfr), intent(in)  FR,
character, dimension(*), intent(in)  UFR,
integer, intent(in)  NLINES,
real, intent(in)  FTOPI,
character, dimension(*), intent(in)  PRVAR,
character, dimension(*), intent(in)  PRUNIT,
character, dimension(*), intent(in)  PNTNME 
)

Definition at line 1366 of file w3arrymd.F90.

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  !/

References w3servmd::strace().

Referenced by w3exnc(), w3expo(), and w3strt().

◆ prt2ds()

subroutine w3arrymd::prt2ds ( integer, intent(in)  NDS,
integer, intent(in)  NFR0,
integer, intent(in)  NFR,
integer, intent(in)  NTH,
real, dimension(nfr0,*), intent(in)  E,
real, dimension(*), intent(in)  FR,
character, dimension(*), intent(in)  UFR,
real, intent(in)  FACSP,
real, intent(in)  FSC,
real, intent(in)  RRCUT,
character, dimension(*), intent(in)  PRVAR,
character, dimension(*), intent(in)  PRUNIT,
character, dimension(*), intent(in)  PNTNME 
)

Definition at line 1943 of file w3arrymd.F90.

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  !/

References angstr(), and w3servmd::strace().

Referenced by w3exnc(), w3expo(), w3iopomd::w3iope(), w3sbt1md::w3sbt1(), w3sdb1md::w3sdb1(), w3src1md::w3sds1(), w3src2md::w3sds2(), w3src3md::w3sds3(), w3src4md::w3sds4(), w3sic1md::w3sic1(), w3sic2md::w3sic2(), w3sic3md::w3sic3(), w3sic4md::w3sic4(), w3sic5md::w3sic5(), w3src1md::w3sin1(), w3src2md::w3sin2(), w3src3md::w3sin3(), w3src4md::w3sin4(), w3sis1md::w3sis1(), w3sis2md::w3sis2(), w3snl1md::w3snl1(), w3snl2md::w3snl2(), w3snlsmd::w3snls(), w3strt(), and w3updtmd::w3ulev().

◆ prtblk()

subroutine w3arrymd::prtblk ( integer, intent(in)  NDS,
integer, intent(in)  NX,
integer, intent(in)  NY,
integer, intent(in)  MX,
real, dimension(mx,ny), intent(in)  F,
integer, dimension(mx,ny), intent(in)  MAP,
integer, intent(in)  MAP0,
real, intent(in)  FSC,
integer, intent(in)  IX1,
integer, intent(in)  IX2,
integer, intent(in)  IX3,
integer, intent(in)  IY1,
integer, intent(in)  IY2,
integer, intent(in)  IY3,
character, dimension(*), intent(in)  PRVAR,
character, dimension(*), intent(in)  PRUNIT 
)

Definition at line 1112 of file w3arrymd.F90.

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  !/

References w3servmd::strace().

Referenced by w3updtmd::w3dzxy(), w3exgo(), w3exnc(), w3grid_interp(), w3initmd::w3init(), w3prep(), w3prnc(), w3strt(), and w3updtmd::w3uini().

yowelementpool::ne
integer, public ne
number of local elements
Definition: yowelementpool.F90:48
w3servmd
Definition: w3servmd.F90:3
angstr
subroutine angstr(IANG, SANG, ILEN, INUM)
Definition: w3arrymd.F90:2290
w3servmd::strace
subroutine strace(IENT, SNAME)
Definition: w3servmd.F90:148
w3servmd::extcde
subroutine extcde(IEXIT, UNIT, MSG, FILE, LINE, COMM)
Definition: w3servmd.F90:736