source: CPL/oasis3/trunk/src/mod/oasis3/src/chkfld.f @ 1677

Last change on this file since 1677 was 1677, checked in by aclsce, 12 years ago

Imported oasis3 (tag ipslcm5a) from cvs server to svn server (igcmg project).

File size: 9.1 KB
Line 
1      SUBROUTINE chkfld (cdname, cdlab, pfild, kmask, psurf, 
2     $    ksize, klon, kflag)
3C****
4C               *****************************
5C               * OASIS ROUTINE  -  LEVEL 0 *
6C               * -------------     ------- *
7C               *****************************
8C
9C**** *chkfld*  - Perform basic checks on a given field array
10C
11C     Purpose:
12C     -------
13C     Calculate mean and extremum values of a real array
14C
15C**   Interface:
16C     ---------
17C       *CALL*  *chkfld (cdname, cdlab, pfild, kmask, psurf, ksize, klon,
18C                        kflag)*
19C
20C     Input:
21C     -----
22C                cdname : symbolic name of the field to be checked
23C                cdlab  : definition of the field to be checked
24C                pfild  : field array (real 1D)
25C                kmask  : associated mask array (integer 1D)
26C                psurf  : surface array (real 1D)
27C                ksize  : field array dimension
28C                klon   : number of longitudes
29C                kflag  : flag to compute integral of field
30C     
31C     Output:
32C     ------
33C     None
34C
35C     Workspace:
36C     ---------
37C     None
38C
39C     Externals:
40C     ---------
41C     ssumr, rmaxim, rminim
42C
43C     Reference:
44C     ---------
45C     See OASIS manual (1995) 
46C
47C     History:
48C     -------
49C       Version   Programmer     Date      Description
50C       -------   ----------     ----      ----------- 
51C       2.1       L. Terray      96/09/25  created
52C       2.3       S. Valcke      99/04/30  added: printing levels
53C
54C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
55C
56C* ---------------------------- Include files ---------------------------
57C
58      USE mod_kinds_oasis
59      USE mod_unit
60      USE mod_printing
61C
62C* ---------------------------- Argument declarations -------------------
63C
64      IMPLICIT NONE
65      EXTERNAL ssumr, rminim, rmaxim
66      INTEGER (kind=ip_intwp_p) ksize 
67      REAL (kind=ip_realwp_p) pfild(ksize), psurf(ksize)
68      REAL (kind=ip_realwp_p) zmean, zglomax, zglomin, zmer, zmermax
69      REAL (kind=ip_realwp_p) zmermin, zterre, zsolmax, zsolmin
70      REAL (kind=ip_realwp_p) ztmp, zglo, zsea, zland
71      REAL (kind=ip_realwp_p) ssumr, rminim, rmaxim
72      INTEGER (kind=ip_intwp_p) iiglomax, ijglomax, iiglomin 
73      INTEGER (kind=ip_intwp_p) ijglomin, imer, iimermax, ijmermax
74      INTEGER (kind=ip_intwp_p) iimermin, ijmermin, iterre, iisolmax 
75      INTEGER (kind=ip_intwp_p) ijsolmax, iisolmin, ijsolmin
76      INTEGER (kind=ip_intwp_p) klon, jn, iflag, isolmin, isolmax
77      INTEGER (kind=ip_intwp_p) imermin, imermax, ji, kflag
78      INTEGER (kind=ip_intwp_p) iglomin, iglomax   
79      INTEGER (kind=ip_intwp_p) kmask(ksize)
80      CHARACTER*8 cdname
81      CHARACTER*32 cdlab
82C
83C* ---------------------------- Poema verses ----------------------------
84C
85C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
86C
87C*    1. Initializations
88C        ---------------
89C
90      IF (nlogprt .GE. 2) THEN
91          WRITE (UNIT = nulou,FMT = *) ' '
92          WRITE (UNIT = nulou,FMT = *) ' '
93          WRITE (UNIT = nulou,FMT = *) 
94     $    '           ROUTINE chkfld  -  Level 0'
95          WRITE (UNIT = nulou,FMT = *) 
96     $    '           **************     *******'
97          WRITE (UNIT = nulou,FMT = *) ' '
98          WRITE (UNIT = nulou,FMT = 1010) cdname, cdlab
99          WRITE (UNIT = nulou,FMT = *) ' '
100          WRITE (UNIT = nulou,FMT = *) ' '
101      ENDIF
102C
103C* Initialization of counters and sums
104C
105      iterre = 0
106      imer = 0
107      zmean = 0.0
108      zterre = 0.0
109      zmer = 0.0
110C
111C* Formats
112C
113 1010 FORMAT(5X,' Field alias name is = ',A8,
114     $     /,5X,' Its definition is   = ',A32)
115C
116C
117C*    2. Basic checks
118C        ------------
119C
120C* Calculate the mean; first the global one
121C
122      IF (ksize .GT. 0) THEN
123          zmean = ssumr (pfild, ksize) / float(ksize)
124        ELSE
125          WRITE(UNIT = nulou,FMT = 2010)
126          CALL HALTE('STOP in chkfld')
127      ENDIF
128C
129C* The other ones
130C
131      DO 210 jn = 1, ksize
132        IF (kmask(jn) .EQ. 0) THEN
133            imer = imer + 1
134            zmer = zmer + pfild(jn)
135          ELSE IF (kmask(jn) .EQ. 1) THEN
136            iterre = iterre + 1
137            zterre = zterre + pfild(jn)
138        ENDIF
139 210  CONTINUE
140      IF (imer .GT. 0) THEN
141          zmer = zmer / float(imer)
142        ELSE
143         WRITE(UNIT = nulou,FMT = 2020)
144         CALL HALTE('STOP in chkfld')
145      ENDIF
146      IF (iterre .GT. 0) THEN
147          zterre = zterre / float(iterre)
148        ELSE
149         WRITE(UNIT = nulou,FMT = 2030)
150      ENDIF
151C
152C* Calculate extrema
153C
154      iflag = 0
155      zglomin = rminim (pfild, kmask, ksize, iglomin, iflag)
156      zglomax = rmaxim (pfild, kmask, ksize, iglomax, iflag)
157C* Indexes for minimum
158      IF (mod(iglomin,klon) .EQ. 0) THEN
159          ijglomin = iglomin / klon
160          iiglomin = klon
161        ELSE
162          ztmp = float(iglomin/klon)
163          ijglomin = int(ztmp) + 1
164          iiglomin = iglomin - (ijglomin -1) * klon
165      ENDIF
166C* Indexes for maximum
167      IF (mod(iglomax,klon) .EQ. 0) THEN
168          ijglomax = iglomax / klon
169          iiglomax = klon
170        ELSE
171          ztmp = float(iglomax/klon)
172          ijglomax = int(ztmp) + 1
173          iiglomax = iglomax - (ijglomax -1) * klon
174      ENDIF
175C
176C* Land
177C
178      iflag = 1
179      zsolmin = rminim (pfild, kmask, ksize, isolmin, iflag)
180      zsolmax = rmaxim (pfild, kmask, ksize, isolmax, iflag)
181C* Indexes for minimum
182      IF (mod(isolmin,klon) .EQ. 0) THEN
183          ijsolmin = isolmin / klon
184          iisolmin = klon
185        ELSE
186          ztmp = float(isolmin/klon)
187          ijsolmin = int(ztmp) + 1
188          iisolmin = isolmin - (ijsolmin -1) * klon
189      ENDIF
190C* Indexes for maximum
191      IF (mod(isolmax,klon) .EQ. 0) THEN
192          ijsolmax = isolmax / klon
193          iisolmax = klon
194        ELSE
195          ztmp = float(isolmax/klon)
196          ijsolmax = int(ztmp) + 1
197          iisolmax = isolmax - (ijsolmax -1) * klon
198      ENDIF
199C
200C* Sea
201C
202      iflag = 2
203      zmermin = rminim (pfild, kmask, ksize, imermin, iflag)
204      zmermax = rmaxim (pfild, kmask, ksize, imermax, iflag)
205C* Indexes for minimum
206      IF (mod(imermin,klon) .EQ. 0) THEN
207          ijmermin = imermin / klon
208          iimermin = klon
209        ELSE
210          ztmp = float(imermin/klon)
211          ijmermin = int(ztmp) + 1
212          iimermin = imermin - (ijmermin -1) * klon
213      ENDIF
214C* Indexes for maximum
215      IF (mod(imermax,klon) .EQ. 0) THEN
216          ijmermax = imermax / klon
217          iimermax = klon
218        ELSE
219          ztmp = float(imermax/klon)
220          ijmermax = int(ztmp) + 1
221          iimermax = imermax - (ijmermax -1) * klon
222      ENDIF
223C
224C* Print results
225C
226      WRITE(UNIT = nulou,FMT = 2040) cdname
227      WRITE(UNIT = nulou,FMT = 2050)
228      WRITE(UNIT = nulou,FMT = 2060) zmean, 
229     $    zglomax, iiglomax, ijglomax,
230     $    zglomin, iiglomin, ijglomin,
231     $    imer, zmer, 
232     $    zmermax, iimermax, ijmermax,
233     $    zmermin, iimermin, ijmermin,
234     $    iterre, zterre, 
235     $    zsolmax, iisolmax, ijsolmax,
236     $    zsolmin, iisolmin, ijsolmin
237C
238C* Formats
239C
240 2010 FORMAT(' WARNING: total number of points .LE. 0 ')
241 2020 FORMAT(' WARNING: number of sea points .LE. 0 ')
242 2030 FORMAT(' WARNING: number of land points .LE. 0 ',
243     $       /,' This must be a sea-world run ')
244 2040 FORMAT(/,15X,'  Field checks: ',A8)
245 2050 FORMAT(15X,'  ************  ',/)
246 2060 FORMAT(/,10X,'  Global average     = ',E22.7,
247     $       /,10X,'  Global maximum     = ',E22.7,
248     $    '  Pt i-j = ',I3,2X,I3,
249     $       /,10X,'  Global minimum     = ',E22.7,
250     $    '  Pt i-j = ',I3,2X,I3,
251     $       /,10X,'  Ocean grid points  = ',I6,
252     $       /,10X,'  Ocean  average     = ',E22.7,
253     $       /,10X,'  Ocean  maximum     = ',E22.7,
254     $    '  Pt i-j = ',I3,2X,I3,
255     $       /,10X,'  Ocean  minimum     = ',E22.7,
256     $    '  Pt i-j = ',I3,2X,I3,
257     $       /,10X,'  Land grid points   = ',I6,
258     $       /,10X,'  Land  average      = ',E22.7,
259     $       /,10X,'  Land  maximum      = ',E22.7,
260     $    '  Pt i-j = ',I3,2X,I3,
261     $       /,10X,'  Land  minimum      = ',E22.7,
262     $    '  Pt i-j = '
263     $    ,I3,2X,I3,/)
264C
265C
266C*    3. Calculate integral of current field if needed
267C        ------------------------------------------------------
268C
269      IF (kflag .EQ. 1) THEN
270          zglo = 0.0
271          zsea = 0.0
272          zland = 0.0
273C
274C* The integral is performed on all and unmasked points
275C
276          DO 310 ji = 1, ksize
277            zsea = zsea + pfild(ji) * psurf(ji) * float(1 - kmask(ji))
278            zland = zland + pfild(ji) * psurf(ji) * float(kmask(ji))
279            zglo = zglo + pfild(ji) * psurf(ji)
280 310      CONTINUE
281          WRITE(UNIT = nulou,FMT = 3010)  zglo, zsea, zland       
282      ENDIF
283C
284C* Formats
285C 
286 3010 FORMAT(/,10X,'  Earth integral       = ',E22.7,
287     $       /,10X,'  Ocean integral       = ',E22.7,
288     $       /,10X,'  Land  integral       = ',E22.7)
289C
290C
291C*    4. End of routine
292C        --------------
293C
294      IF (nlogprt .GE. 2) THEN
295          WRITE (UNIT = nulou,FMT = *) ' '
296          WRITE (UNIT = nulou,FMT = *) 
297     $    '          ---------- End of routine chkfld --------'
298          CALL FLUSH (nulou)
299      ENDIF
300      RETURN
301      END
302
303
Note: See TracBrowser for help on using the repository browser.