/[MITgcm]/MITgcm_contrib/quarter_degree_global/code_srdiags_call/srdiags_f77.F
ViewVC logotype

Contents of /MITgcm_contrib/quarter_degree_global/code_srdiags_call/srdiags_f77.F

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph


Revision 1.2 - (show annotations) (download)
Fri Jul 28 22:17:36 2006 UTC (19 years ago) by cnh
Branch: MAIN
CVS Tags: HEAD
Changes since 1.1: +39 -0 lines
Added 1/8 numbers

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

  ViewVC Help
Powered by ViewVC 1.1.22