1 |
#include "CPP_OPTIONS.h" |
2 |
|
3 |
SUBROUTINE SRDIAGS_F77_INIT( myThid ) |
4 |
|
5 |
C == Global declarations == |
6 |
USE SRDIAGS |
7 |
IMPLICIT NONE |
8 |
|
9 |
#include "SIZE.h" |
10 |
#include "EEPARAMS.h" |
11 |
#include "EESUPPORT.h" |
12 |
#include "SRDIAG.h" |
13 |
|
14 |
C == Routine arguments == |
15 |
INTEGER myThid |
16 |
|
17 |
C == Local variables == |
18 |
CHARACTER*512 srFnamePref |
19 |
REAL*8 ap |
20 |
TYPE(SRDIAG_SPEC), POINTER :: diagVar |
21 |
INTEGER I, J |
22 |
INTEGER iG, jG, bi, bj |
23 |
|
24 |
CALL SRDIAG_INIT( myThid ) |
25 |
|
26 |
C Sub-region 1, 4 hourly averaged diagnostic field |
27 |
C Sub-region 2, 12 hourly averaged open boundary fields for rerun |
28 |
DO I=1, 2 |
29 |
WRITE( srFnamePref, '(A,I4.4,A,I6.6)' ) |
30 |
& 'srdiag.',I,'.',myProcId |
31 |
IF ( I .EQ. 1 ) THEN |
32 |
ap = 3600. _d 0 * 4. _d 0 |
33 |
ap = 3600. _d 0 * 24. _d 0 * 2. _d 0 |
34 |
ENDIF |
35 |
IF ( I .EQ. 2 ) THEN |
36 |
ap = 3600. _d 0 * 12. _d 0 |
37 |
ap = 3600. _d 0 * 24. _d 0 * 5. _d 0 |
38 |
ENDIF |
39 |
IF ( I.EQ.1) THEN |
40 |
CALL SRDIAG_CREATE( dv1, ap, srFnamePref, myThid ) |
41 |
ENDIF |
42 |
IF ( I.EQ.2) THEN |
43 |
CALL SRDIAG_CREATE( dv2, ap, srFnamePref, myThid ) |
44 |
ENDIF |
45 |
ENDDO |
46 |
C |
47 |
C Add regions |
48 |
C sr 1 |
49 |
diagVar => dv1 |
50 |
DO bj=myByLo(myThid),myByHi(myThid) |
51 |
DO bi=myBxLo(myThid),myBxHi(myThid) |
52 |
C-- "Global" index (place holder) |
53 |
jG = myYGlobalLo + (bj-1)*sNy |
54 |
iG = myXGlobalLo + (bi-1)*sNx |
55 |
C-- North Atlantic |
56 |
CALL SRDIAG_ADD_REGION( |
57 |
I iG, jG, 1, |
58 |
I sNx, sNy, Nr, |
59 |
I 65, 18, 1, |
60 |
I 26, 20, 10, |
61 |
U diagVar, |
62 |
I myThid ) |
63 |
CALL SRDIAG_ADD_REGION( |
64 |
I iG, jG, 1, |
65 |
I sNx, sNy, Nr, |
66 |
I 1, 18, 1, |
67 |
I 6, 20, 10, |
68 |
U diagVar, |
69 |
I myThid ) |
70 |
C-- Hawaii |
71 |
CALL SRDIAG_ADD_REGION( |
72 |
I iG, jG, 1, |
73 |
I sNx, sNy, Nr, |
74 |
I 46, 20, 1, |
75 |
I 6, 6, 10, |
76 |
U diagVar, |
77 |
I myThid ) |
78 |
C-- Kuroishio |
79 |
CALL SRDIAG_ADD_REGION( |
80 |
I iG, jG, 1, |
81 |
I sNx, sNy, Nr, |
82 |
I 32, 22, 1, |
83 |
I 10, 6, 10, |
84 |
U diagVar, |
85 |
I myThid ) |
86 |
C-- Drake passage |
87 |
CALL SRDIAG_ADD_REGION( |
88 |
I iG, jG, 1, |
89 |
I sNx, sNy, Nr, |
90 |
I 60, 3, 1, |
91 |
I 23, 7, 10, |
92 |
U diagVar, |
93 |
I myThid ) |
94 |
C-- North Atlantic |
95 |
C8 CALL SRDIAG_ADD_REGION( |
96 |
C8 I iG, jG, 1, |
97 |
C8 I sNx, sNy, Nr, |
98 |
C8 I 2080, 890, 1, |
99 |
C8 I 801, 771, 17, |
100 |
C8 U diagVar, |
101 |
C8 I myThid ) |
102 |
C8 CALL SRDIAG_ADD_REGION( |
103 |
C8 I iG, jG, 1, |
104 |
C8 I sNx, sNy, Nr, |
105 |
C8 I 1, 890, 1, |
106 |
C8 I 140, 771, 17, |
107 |
C8 U diagVar, |
108 |
C8 I myThid ) |
109 |
C-- Hawaii |
110 |
C8 CALL SRDIAG_ADD_REGION( |
111 |
C8 I iG, jG, 1, |
112 |
C8 I sNx, sNy, Nr, |
113 |
C8 I 1540,1140, 1, |
114 |
C8 I 161, 171, 17, |
115 |
C8 U diagVar, |
116 |
C8 I myThid ) |
117 |
C-- Kuroishio |
118 |
C8 CALL SRDIAG_ADD_REGION( |
119 |
C8 I iG, jG, 1, |
120 |
C8 I sNx, sNy, Nr, |
121 |
C8 I 1000,1250, 1, |
122 |
C8 I 401, 251, 17, |
123 |
C8 U diagVar, |
124 |
C8 I myThid ) |
125 |
C-- Drake passage |
126 |
C8 CALL SRDIAG_ADD_REGION( |
127 |
C8 I iG, jG, 1, |
128 |
C8 I sNx, sNy, Nr, |
129 |
C8 I 1900, 300, 1, |
130 |
C8 I 701, 251, 17, |
131 |
C8 U diagVar, |
132 |
C8 I myThid ) |
133 |
ENDDO |
134 |
ENDDO |
135 |
C sr 2 |
136 |
diagVar => dv2 |
137 |
C full depth slice every ten cells |
138 |
DO bj=myByLo(myThid),myByHi(myThid) |
139 |
DO bi=myBxLo(myThid),myBxHi(myThid) |
140 |
C-- "Global" index (place holder) |
141 |
jG = myYGlobalLo + (bj-1)*sNy |
142 |
iG = myXGlobalLo + (bi-1)*sNx |
143 |
C-- constant I lines |
144 |
DO I=iG,iG+sNx-1 |
145 |
IF ( INT(I/10)*10 .EQ. I ) THEN |
146 |
CALL SRDIAG_ADD_REGION( |
147 |
I iG, jG, 1, |
148 |
I sNx, sNy, Nr, |
149 |
I I, jG, 1, |
150 |
I 1, sNy, Nr, |
151 |
U diagVar, |
152 |
I myThid ) |
153 |
ENDIF |
154 |
ENDDO |
155 |
C-- constant J lines |
156 |
DO J=jG,jG+sNy-1 |
157 |
IF ( INT(J/10)*10 .EQ. J ) THEN |
158 |
CALL SRDIAG_ADD_REGION( |
159 |
I iG, jG, 1, |
160 |
I sNx, sNy, Nr, |
161 |
I iG, J, 1, |
162 |
I sNx, 1, Nr, |
163 |
U diagVar, |
164 |
I myThid ) |
165 |
ENDIF |
166 |
ENDDO |
167 |
ENDDO |
168 |
ENDDO |
169 |
|
170 |
RETURN |
171 |
END |
172 |
|
173 |
SUBROUTINE SRDIAGS_F77_ADDCODES( myThid ) |
174 |
|
175 |
C == Global declarations == |
176 |
USE SRDIAGS |
177 |
IMPLICIT NONE |
178 |
|
179 |
#include "SIZE.h" |
180 |
#include "EEPARAMS.h" |
181 |
#include "EESUPPORT.h" |
182 |
#include "PARAMS.h" |
183 |
#include "SRDIAG.h" |
184 |
|
185 |
C == Routine arguments == |
186 |
INTEGER myThid |
187 |
|
188 |
C == Local variables == |
189 |
CHARACTER*512 fCode |
190 |
INTEGER bi, bj, iG, jG |
191 |
TYPE(SRDIAG_SPEC), POINTER :: diagVar |
192 |
INTEGER I |
193 |
|
194 |
DO I=1, 2 |
195 |
IF ( I.EQ. 1 ) THEN |
196 |
diagVar => dv1 |
197 |
ENDIF |
198 |
IF ( I.EQ. 2 ) THEN |
199 |
diagVar => dv2 |
200 |
ENDIF |
201 |
DO bj=myByLo(myThid),myByHi(myThid) |
202 |
DO bi=myBxLo(myThid),myBxHi(myThid) |
203 |
|
204 |
WRITE( fCode, '(A,I4.4,A,I4.4)' ) 'ETAN:',bi,':',bj |
205 |
jG = myYGlobalLo + (bj-1)*sNy |
206 |
iG = myXGlobalLo + (bi-1)*sNx |
207 |
CALL SRDIAG_ADD_FCODE(fCode, (/iG-1, jG-1, 0/), |
208 |
I 'XYZ',diagVar, deltatClock, myThid ) |
209 |
|
210 |
WRITE( fCode, '(A,I4.4,A,I4.4)' ) 'UVEL:',bi,':',bj |
211 |
jG = myYGlobalLo + (bj-1)*sNy |
212 |
iG = myXGlobalLo + (bi-1)*sNx |
213 |
CALL SRDIAG_ADD_FCODE(fCode, (/iG-1, jG-1, 0/), |
214 |
I 'XYZ',diagVar, deltatClock, myThid ) |
215 |
|
216 |
WRITE( fCode, '(A,I4.4,A,I4.4)' ) 'VVEL:',bi,':',bj |
217 |
jG = myYGlobalLo + (bj-1)*sNy |
218 |
iG = myXGlobalLo + (bi-1)*sNx |
219 |
CALL SRDIAG_ADD_FCODE(fCode, (/iG-1, jG-1, 0/), |
220 |
I 'XYZ',diagVar, deltatClock, myThid ) |
221 |
|
222 |
WRITE( fCode, '(A,I4.4,A,I4.4)' ) 'WVEL:',bi,':',bj |
223 |
jG = myYGlobalLo + (bj-1)*sNy |
224 |
iG = myXGlobalLo + (bi-1)*sNx |
225 |
CALL SRDIAG_ADD_FCODE(fCode, (/iG-1, jG-1, 0/), |
226 |
I 'XYZ',diagVar, deltatClock, myThid ) |
227 |
|
228 |
WRITE( fCode, '(A,I4.4,A,I4.4)' ) 'SALTanom:',bi,':',bj |
229 |
jG = myYGlobalLo + (bj-1)*sNy |
230 |
iG = myXGlobalLo + (bi-1)*sNx |
231 |
CALL SRDIAG_ADD_FCODE(fCode, (/iG-1, jG-1, 0/), |
232 |
I 'XYZ',diagVar, deltatClock, myThid ) |
233 |
|
234 |
WRITE( fCode, '(A,I4.4,A,I4.4)' ) 'SALT:',bi,':',bj |
235 |
jG = myYGlobalLo + (bj-1)*sNy |
236 |
iG = myXGlobalLo + (bi-1)*sNx |
237 |
CALL SRDIAG_ADD_FCODE(fCode, (/iG-1, jG-1, 0/), |
238 |
I 'XYZ',diagVar, deltatClock, myThid ) |
239 |
|
240 |
WRITE( fCode, '(A,I4.4,A,I4.4)' ) 'THETA:',bi,':',bj |
241 |
jG = myYGlobalLo + (bj-1)*sNy |
242 |
iG = myXGlobalLo + (bi-1)*sNx |
243 |
CALL SRDIAG_ADD_FCODE(fCode, (/iG-1, jG-1, 0/), |
244 |
I 'XYZ',diagVar, deltatClock, myThid ) |
245 |
|
246 |
WRITE( fCode, '(A,I4.4,A,I4.4)' ) 'WVELMASS:',bi,':',bj |
247 |
jG = myYGlobalLo + (bj-1)*sNy |
248 |
iG = myXGlobalLo + (bi-1)*sNx |
249 |
CALL SRDIAG_ADD_FCODE(fCode, (/iG-1, jG-1, 0/), |
250 |
I 'XYZ',diagVar, deltatClock, myThid ) |
251 |
|
252 |
WRITE( fCode, '(A,I4.4,A,I4.4)' ) 'RHOAnoma:',bi,':',bj |
253 |
jG = myYGlobalLo + (bj-1)*sNy |
254 |
iG = myXGlobalLo + (bi-1)*sNx |
255 |
CALL SRDIAG_ADD_FCODE(fCode, (/iG-1, jG-1, 0/), |
256 |
I 'XYZ',diagVar, deltatClock, myThid ) |
257 |
|
258 |
ENDDO |
259 |
ENDDO |
260 |
ENDDO |
261 |
|
262 |
RETURN |
263 |
END |
264 |
|
265 |
! CALL SRDIAGS_F77_FILL( charDiag, |
266 |
! I inpFld, iFldParms, biArg, bjArg, |
267 |
! I myThid) |
268 |
|
269 |
SUBROUTINE SRDIAGS_F77_FILL( fName, |
270 |
I inpFld, iFldParms, biArg, bjArg, |
271 |
I myThid ) |
272 |
|
273 |
C == Global declarations == |
274 |
USE SRDIAGS |
275 |
IMPLICIT NONE |
276 |
|
277 |
#include "SIZE.h" |
278 |
#include "EEPARAMS.h" |
279 |
#include "EESUPPORT.h" |
280 |
#include "DYNVARS.h" |
281 |
#include "SRDIAG.h" |
282 |
|
283 |
C == Routine arguments == |
284 |
CHARACTER*8 fName |
285 |
_RL inpFld(*) |
286 |
INTEGER iFldParms(8) |
287 |
INTEGER biArg |
288 |
INTEGER bjArg |
289 |
INTEGER myThid |
290 |
|
291 |
C == Local variables == |
292 |
REAL*8, POINTER :: srBuf( :,:,:,:,:) |
293 |
REAL*8, POINTER :: srTemp( :,:,:) |
294 |
REAL*8, POINTER :: tempBuf(:,:,:,:,:) |
295 |
INTEGER iLo, iHi, jLo, jHi, srK, biLo, biHi, bjLo, bjHi |
296 |
INTEGER kLev, mynR, mynTx, mynTy |
297 |
INTEGER iLoInp, iHiInp, jLoInp, jHiInp, srKLo, srKHi |
298 |
INTEGER I,J,K,bi,bj,iB |
299 |
|
300 |
CHARACTER*512 fCode |
301 |
TYPE(SRDIAG_SPEC), POINTER :: diagVar |
302 |
|
303 |
! PRINT *, 'SRDIAGS_FILE fName ', fName |
304 |
! PRINT *, ' iLo, iHi, jLo, jHi', |
305 |
! & iFldParms(1), iFldParms(2), iFldParms(3), iFldParms(4) |
306 |
! PRINT *, ' nR, kLev ', iFldParms(5), iFldParms(8) |
307 |
! PRINT *, ' nTx, nTy ', iFldParms(6), iFldParms(7) |
308 |
! PRINT *, ' biArg, bjArg ', biArg, bjArg |
309 |
|
310 |
C Figure out dimensions of buffer to use |
311 |
C Horiz extents |
312 |
iLo = 1 |
313 |
iHi = sNx |
314 |
jLo = 1 |
315 |
jHi = sNy |
316 |
iLoInp = iFldParms(1) |
317 |
iHiInp = iFldParms(2) |
318 |
jLoInp = iFldParms(3) |
319 |
jHiInp = iFldParms(4) |
320 |
C Vertical |
321 |
kLev = iFldParms(8) |
322 |
mynR = iFldParms(5) |
323 |
IF ( kLev .EQ. 0 ) THEN |
324 |
C All levels have been given |
325 |
srKLo = 1 |
326 |
srKHi = mynR |
327 |
ENDIF |
328 |
IF ( kLev .GT. 0 ) THEN |
329 |
C A specific level has been given |
330 |
srKLo = kLev |
331 |
srKHi = kLev |
332 |
ENDIF |
333 |
mynTx = iFldParms(6) |
334 |
mynTy = iFldParms(7) |
335 |
C The lines below do not work for multi-threaded decomposition |
336 |
C For multi-threaded decomp. biLo would not be 1, with the |
337 |
C values from myBiLo etc... |
338 |
IF ( mynTx .GT. 1 .OR. mynTy .GT. 1 ) THEN |
339 |
C We have multiple tiles passed in. |
340 |
biLo=1 |
341 |
biHi=mynTx |
342 |
bjLo=1 |
343 |
bjHi=mynTy |
344 |
ELSE |
345 |
C We have one tile passed in. |
346 |
biLo=biArg |
347 |
biHi=biArg |
348 |
bjLo=bjArg |
349 |
bjHi=bjArg |
350 |
ENDIF |
351 |
|
352 |
ALLOCATE( srBuf(iLo:iHi,jLo:jHi,srKLo:srKHi,biLo:biHi,bjLo:bjHi) ) |
353 |
! ALLOCATE( srTemp(iLo:iHi,jLo:jHi,srKLo:srKHi) ) |
354 |
|
355 |
! Unravel inpFld |
356 |
ALLOCATE( |
357 |
& tempBuf(iLoInp:iHiInp,jLoInp:jHiInp, |
358 |
& srKLo:srKHi,biLo:biHi,bjLo:bjHi) |
359 |
&) |
360 |
iB = 0 |
361 |
DO bj=bjLo,bjHi |
362 |
DO bi=biLo,biHi |
363 |
DO K=srKLo,srKHi |
364 |
DO J=jLoInp,jHiInp |
365 |
DO I=iLoInp,iHiInp |
366 |
iB = iB+1 |
367 |
tempBuf(I,J,K,bi,bj)=inpFld(iB) |
368 |
ENDDO |
369 |
ENDDO |
370 |
ENDDO |
371 |
ENDDO |
372 |
ENDDO |
373 |
! IF ( fName .EQ. 'ETAN' ) THEN |
374 |
! PRINT *, ' bjLo, bjHi, biLo, biHi ', bjLo, bjHi, biLo, biHi |
375 |
! PRINT *, ' srKlo, srKHi ', srKLo, srKHi |
376 |
! ENDIF |
377 |
|
378 |
! Extract the part we are interested in |
379 |
! ALLOCATE( srTemp(iLo:iHi,jLo:jHi,srKLo:srKHi) ) |
380 |
srBuf = |
381 |
& tempBuf(iLo:iHi,jLo:jHi,srKLo:srKHi,biLo:biHi,bjLo:bjHi) |
382 |
DEALLOCATE(tempBuf) |
383 |
|
384 |
! Push output to srdiags buffers |
385 |
ALLOCATE( srTemp(iLo:iHi,jLo:jHi,srKLo:srKHi) ) |
386 |
DO bj=bjLo,bjHi |
387 |
DO bi=biLo,biHi |
388 |
srTemp = srBuf(:,:,:,bi,bj) |
389 |
! IF ( fName .EQ. 'ETAN' ) THEN |
390 |
diagVar => dv1 |
391 |
WRITE( fCode, '(A,A,I4.4,A,I4.4)' ) TRIM(fName),':',bi,':',bj |
392 |
CALL SRDIAG_FILL( srTemp, 1.d0, fCode, diagVar, myThid ) |
393 |
diagVar => dv2 |
394 |
WRITE( fCode, '(A,A,I4.4,A,I4.4)' ) TRIM(fName),':',bi,':',bj |
395 |
CALL SRDIAG_FILL( srTemp, 1.d0, fCode, diagVar, myThid ) |
396 |
! ENDIF |
397 |
ENDDO |
398 |
ENDDO |
399 |
|
400 |
DEALLOCATE(srTemp ) |
401 |
DEALLOCATE(srBuf ) |
402 |
|
403 |
|
404 |
RETURN |
405 |
END |
406 |
|
407 |
SUBROUTINE SRDIAGS_F77_SAVEFIELDS( myTime, myIter, myThid ) |
408 |
|
409 |
C == Global declarations == |
410 |
USE SRDIAGS |
411 |
IMPLICIT NONE |
412 |
|
413 |
#include "SIZE.h" |
414 |
#include "EEPARAMS.h" |
415 |
#include "EESUPPORT.h" |
416 |
#include "PARAMS.h" |
417 |
#include "DYNVARS.h" |
418 |
#include "SRDIAG.h" |
419 |
LOGICAL DIFFERENT_MULTIPLE |
420 |
EXTERNAL DIFFERENT_MULTIPLE |
421 |
|
422 |
C == Routine arguments == |
423 |
INTEGER myThid |
424 |
_RL myTime |
425 |
INTEGER myIter |
426 |
|
427 |
C == Local variables == |
428 |
CHARACTER*512 fCode |
429 |
REAL*8 tmpFldXYZ(1:sNx,1:sNy,Nr) |
430 |
REAL*8 tmpFldXY(1:sNx,1:sNy,1) |
431 |
INTEGER bi, bj, iG, jG |
432 |
TYPE(SRDIAG_SPEC), POINTER :: diagVar |
433 |
INTEGER I |
434 |
|
435 |
! DO I=1, 2 |
436 |
! IF ( I .EQ. 1 ) THEN |
437 |
! diagVar => dv1 |
438 |
! ENDIF |
439 |
! IF ( I .EQ. 2 ) THEN |
440 |
! diagVar => dv2 |
441 |
! ENDIF |
442 |
! DO bj=myByLo(myThid),myByHi(myThid) |
443 |
! DO bi=myBxLo(myThid),myBxHi(myThid) |
444 |
! WRITE( fCode, '(A,I4.4,A,I4.4)' ) 'U:',bi,':',bj |
445 |
! tmpFldXYZ = uVel(1:sNx,1:sNy,:,bi,bj) |
446 |
! CALL SRDIAG_FILL( tmpFldXYZ, 1.d0, fCode, diagVar, myThid ) |
447 |
! ENDDO |
448 |
! ENDDO |
449 |
! DO bj=myByLo(myThid),myByHi(myThid) |
450 |
! DO bi=myBxLo(myThid),myBxHi(myThid) |
451 |
! WRITE( fCode, '(A,I4.4,A,I4.4)' ) 'etan:',bi,':',bj |
452 |
! tmpFldXY(:,:,1) = etan(1:sNx,1:sNy,bi,bj) |
453 |
! CALL SRDIAG_FILL( tmpFldXY, 1.d0, fCode, diagVar, myThid ) |
454 |
! ENDDO |
455 |
! ENDDO |
456 |
! ENDDO |
457 |
|
458 |
C Write to disk if need be |
459 |
diagVar => dv1 |
460 |
IF ( DIFFERENT_MULTIPLE( diagVar%aPeriod, myTime, deltaTClock ) ) THEN |
461 |
CALL SRDIAG_STORE( diagVar, myTime, myThid ) |
462 |
ENDIF |
463 |
|
464 |
diagVar => dv2 |
465 |
IF ( DIFFERENT_MULTIPLE( diagVar%aPeriod, myTime, deltaTClock ) ) THEN |
466 |
CALL SRDIAG_STORE( diagVar, myTime, myThid ) |
467 |
ENDIF |
468 |
|
469 |
C STOP |
470 |
|
471 |
RETURN |
472 |
END |
473 |
|
474 |
SUBROUTINE SRDIAGS_F77_OUTPUT( myThid ) |
475 |
|
476 |
C == Global declarations == |
477 |
USE SRDIAGS |
478 |
IMPLICIT NONE |
479 |
|
480 |
#include "SIZE.h" |
481 |
#include "EEPARAMS.h" |
482 |
#include "EESUPPORT.h" |
483 |
#include "SRDIAG.h" |
484 |
|
485 |
C == Routine arguments == |
486 |
INTEGER myThid |
487 |
|
488 |
C == Local variables == |
489 |
INTEGER I |
490 |
REAL*8 curTime |
491 |
TYPE(SRDIAG_SPEC), POINTER :: diagVar |
492 |
|
493 |
curTime = 0. |
494 |
DO I=1, 2 |
495 |
IF ( I .EQ. 1 ) THEN |
496 |
diagVar => dv1 |
497 |
ENDIF |
498 |
IF ( I .EQ. 2 ) THEN |
499 |
diagVar => dv2 |
500 |
ENDIF |
501 |
CALL SRDIAG_STORE( diagVar, curTime, myThid ) |
502 |
ENDDO |
503 |
|
504 |
RETURN |
505 |
END |