/[MITgcm]/MITgcm/pkg/diagnostics/diagnostics_fill_field.F
ViewVC logotype

Diff of /MITgcm/pkg/diagnostics/diagnostics_fill_field.F

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

revision 1.5 by jmc, Tue Feb 5 15:31:19 2008 UTC revision 1.6 by jmc, Thu Sep 3 20:39:18 2009 UTC
# Line 6  C $Name$ Line 6  C $Name$
6  C--   File diagnostics_fill_field.F:  C--   File diagnostics_fill_field.F:
7  C--    Contents:  C--    Contents:
8  C--    o DIAGNOSTICS_FILL_FIELD  C--    o DIAGNOSTICS_FILL_FIELD
9  C--    o DIAGNOSTICS_DO_FILL  C--    o DIAGNOSTICS_CUMULATE
10    
11  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
12  CBOP  CBOP
13  C     !ROUTINE: DIAGNOSTICS_FILL_FIELD  C     !ROUTINE: DIAGNOSTICS_FILL_FIELD
14  C     !INTERFACE:  C     !INTERFACE:
15        SUBROUTINE DIAGNOSTICS_FILL_FIELD(        SUBROUTINE DIAGNOSTICS_FILL_FIELD(
16       I               inpFld, fractFld, scaleFact, power, nLevFract,       I               inpFldRL, fracFldRL, inpFldRS, fracFldRS,
17         I               scaleFact, power, arrType, nLevFrac,
18       I               ndiagnum, ipointer, kLev, nLevs,       I               ndiagnum, ipointer, kLev, nLevs,
19       I               bibjFlg, biArg, bjArg, myThid )       I               bibjFlg, biArg, bjArg, myThid )
20    
# Line 37  C     !INPUT PARAMETERS: Line 38  C     !INPUT PARAMETERS:
38  C***********************************************************************  C***********************************************************************
39  C  Arguments Description  C  Arguments Description
40  C  ----------------------  C  ----------------------
41  C     inpFld    :: Field to increment diagnostics array  C     inpFldRL  :: Field to increment diagnostics array (arrType=0,1)
42  C     fractFld  :: fraction used for weighted average diagnostics  C     fracFldRL :: fraction used for weighted average diagnostics (arrType=0,2)
43    C     inpFldRS  :: Field to increment diagnostics array (arrType=2,3)
44    C     fracFldRS :: fraction used for weighted average diagnostics (arrType=1,3)
45  C     scaleFact :: scaling factor  C     scaleFact :: scaling factor
46  C     power     :: option to fill-in with the field square (power=2)  C     power     :: option to fill-in with the field square (power=2)
47  C     nLevFract :: number of levels of the fraction field, =0 : do not use fraction  C     arrType   :: select which array & fraction (RL/RS) to process:
48    C                  0: both RL ; 1: inpRL & fracRS ; 2: inpRS,fracRL ; 3: both RS
49    C     nLevFrac  :: number of levels of the fraction field, =0: do not use fraction
50  C     ndiagnum  :: Diagnostics Number (in available diag list) of diag to process  C     ndiagnum  :: Diagnostics Number (in available diag list) of diag to process
51  C     ipointer  :: Pointer to the slot in qdiag to fill  C     ipointer  :: Pointer to the slot in qdiag to fill
52  C     kLev      :: Integer flag for vertical levels:  C     kLev      :: Integer flag for vertical levels:
# Line 68  C                  NOTE: User beware! If Line 73  C                  NOTE: User beware! If
73  C                        is sent here, bibjFlg MUST NOT be set to 0  C                        is sent here, bibjFlg MUST NOT be set to 0
74  C                        or there will be out of bounds problems!  C                        or there will be out of bounds problems!
75  C***********************************************************************  C***********************************************************************
76        _RL inpFld(*)        _RL inpFldRL(*)
77        _RL fractFld(*)        _RL fracFldRL(*)
78          _RS inpFldRS(*)
79          _RS fracFldRS(*)
80        _RL scaleFact        _RL scaleFact
81        INTEGER power        INTEGER power
82        INTEGER nLevFract        INTEGER arrType
83          INTEGER nLevFrac
84        INTEGER ndiagnum, ipointer        INTEGER ndiagnum, ipointer
85        INTEGER kLev, nLevs, bibjFlg, biArg, bjArg        INTEGER kLev, nLevs, bibjFlg, biArg, bjArg
86        INTEGER myThid        INTEGER myThid
# Line 177  C         and do the loop >> do k=kFirst Line 185  C         and do the loop >> do k=kFirst
185            kd0 = ipointer + kLev - 1            kd0 = ipointer + kLev - 1
186          ENDIF          ENDIF
187  C-      Set fraction-weight option :  C-      Set fraction-weight option :
188          useFract = nLevFract.GT.0          useFract = nLevFrac.GT.0
189          IF ( useFract ) THEN          IF ( useFract ) THEN
190            sizF = nLevFract            sizF = nLevFrac
191          ELSE          ELSE
192            sizF = 1            sizF = 1
193          ENDIF          ENDIF
# Line 210  C-      Check for consistency with Nb of Line 218  C-      Check for consistency with Nb of
218            DO bi=myBxLo(myThid), myBxHi(myThid)            DO bi=myBxLo(myThid), myBxHi(myThid)
219             DO k = kFirst,kLast             DO k = kFirst,kLast
220              kd = kd0 + ksgn*k              kd = kd0 + ksgn*k
221              CALL DIAGNOSTICS_DO_FILL(              CALL DIAGNOSTICS_CUMULATE(
222       U                  qdiag(1-OLx,1-OLy,kd,bi,bj),       U                  qdiag(1-OLx,1-OLy,kd,bi,bj),
223       I                  inpFld, fractFld,       I                  inpFldRL, fracFldRL, inpFldRS, fracFldRS,
224       I                  scaleFact, power, useFract,sizF,       I                  scaleFact, power, arrType, useFract, sizF,
225       I                  sizI1,sizI2,sizJ1,sizJ2,nLevs,sizTx,sizTy,       I                  sizI1,sizI2,sizJ1,sizJ2,nLevs,sizTx,sizTy,
226       I                  iRun,jRun,k,bi,bj,       I                  iRun,jRun,k,bi,bj,
227       I                  myThid)       I                  myThid)
# Line 225  C-      Check for consistency with Nb of Line 233  C-      Check for consistency with Nb of
233            bj = MIN(bjArg,sizTy)            bj = MIN(bjArg,sizTy)
234            DO k = kFirst,kLast            DO k = kFirst,kLast
235              kd = kd0 + ksgn*k              kd = kd0 + ksgn*k
236              CALL DIAGNOSTICS_DO_FILL(              CALL DIAGNOSTICS_CUMULATE(
237       U                  qdiag(1-OLx,1-OLy,kd,biArg,bjArg),       U                  qdiag(1-OLx,1-OLy,kd,biArg,bjArg),
238       I                  inpFld, fractFld,       I                  inpFldRL, fracFldRL, inpFldRS, fracFldRS,
239       I                  scaleFact, power, useFract,sizF,       I                  scaleFact, power, arrType, useFract, sizF,
240       I                  sizI1,sizI2,sizJ1,sizJ2,nLevs,sizTx,sizTy,       I                  sizI1,sizI2,sizJ1,sizJ2,nLevs,sizTx,sizTy,
241       I                  iRun,jRun,k,bi,bj,       I                  iRun,jRun,k,bi,bj,
242       I                  myThid)       I                  myThid)
# Line 249  c    &        ' But it is not a valid (o Line 257  c    &        ' But it is not a valid (o
257  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
258    
259  CBOP  CBOP
260  C     !ROUTINE: DIAGNOSTICS_DO_FILL  C     !ROUTINE: DIAGNOSTICS_CUMULATE
261  C     !INTERFACE:  C     !INTERFACE:
262        SUBROUTINE DIAGNOSTICS_DO_FILL(        SUBROUTINE DIAGNOSTICS_CUMULATE(
263       U                  cumFld,       U                  cumFld,
264       I                  inpFld, frcFld,       I                  inpFldRL, frcFldRL, inpFldRS, frcFldRS,
265       I                  scaleFact, power, useFract, sizF,       I                  scaleFact, power, arrType, useFract, sizF,
266       I                  sizI1,sizI2,sizJ1,sizJ2,sizK,sizTx,sizTy,       I                  sizI1,sizI2,sizJ1,sizJ2,sizK,sizTx,sizTy,
267       I                  iRun,jRun,k,bi,bj,       I                  iRun,jRun,k,bi,bj,
268       I                  myThid)       I                  myThid )
269    
270  C     !DESCRIPTION:  C     !DESCRIPTION:
271  C     Update array cumFld  C     Update array cumFld
# Line 273  C     !USES: Line 281  C     !USES:
281  C     !INPUT/OUTPUT PARAMETERS:  C     !INPUT/OUTPUT PARAMETERS:
282  C     == Routine Arguments ==  C     == Routine Arguments ==
283  C     cumFld      :: cumulative array (updated)  C     cumFld      :: cumulative array (updated)
284  C     inpFld      :: input field array to add to cumFld  C     inpFldRL    :: input field array to add to cumFld (arrType=0,1)
285  C     frcFld      :: fraction used for weighted-average diagnostics  C     frcFldRL    :: fraction used for weighted-average diagnostics (arrType=0,2)
286    C     inpFldRS    :: input field array to add to cumFld (arrType=2,3)
287    C     frcFldRS    :: fraction used for weighted-average diagnostics (arrType=1,3)
288  C     scaleFact   :: scaling factor  C     scaleFact   :: scaling factor
289  C     power       :: option to fill-in with the field square (power=2)  C     power       :: option to fill-in with the field square (power=2)
290    C     arrType     :: select which array & fraction (RL/RS) to process:
291    C                    0: both RL ; 1: inpRL & fracRS ; 2: inpRS,fracRL ; 3: both RS
292  C     useFract    :: if True, use fraction-weight  C     useFract    :: if True, use fraction-weight
293  C     sizF        :: size of frcFld array: 3rd  dimension  C     sizF        :: size of frcFld array: 3rd  dimension
294  C     sizI1,sizI2 :: size of inpFld array: 1rst index range (min,max)  C     sizI1,sizI2 :: size of inpFld array: 1rst index range (min,max)
# Line 284  C     sizJ1,sizJ2 :: size of inpFld arra Line 296  C     sizJ1,sizJ2 :: size of inpFld arra
296  C     sizK        :: size of inpFld array: 3rd  dimension  C     sizK        :: size of inpFld array: 3rd  dimension
297  C     sizTx,sizTy :: size of inpFld array: tile dimensions  C     sizTx,sizTy :: size of inpFld array: tile dimensions
298  C     iRun,jRun   :: range of 1rst & 2nd index  C     iRun,jRun   :: range of 1rst & 2nd index
299  C     k,bi,bj     :: level and tile indices of inFld array  C     k,bi,bj     :: level and tile indices of inFld array to add to cumFld array
 C                    to add to cumFld array  
300  C     myThid      :: my Thread Id number  C     myThid      :: my Thread Id number
301        _RL cumFld(1-OLx:sNx+OLx,1-OLy:sNy+OLy)        _RL cumFld(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
302        INTEGER sizI1,sizI2,sizJ1,sizJ2        INTEGER sizI1,sizI2,sizJ1,sizJ2
303        INTEGER sizF,sizK,sizTx,sizTy        INTEGER sizF,sizK,sizTx,sizTy
304        _RL inpFld(sizI1:sizI2,sizJ1:sizJ2,sizK,sizTx,sizTy)        _RL inpFldRL(sizI1:sizI2,sizJ1:sizJ2,sizK,sizTx,sizTy)
305        _RL frcFld(sizI1:sizI2,sizJ1:sizJ2,sizF,sizTx,sizTy)        _RL frcFldRL(sizI1:sizI2,sizJ1:sizJ2,sizF,sizTx,sizTy)
306          _RS inpFldRS(sizI1:sizI2,sizJ1:sizJ2,sizK,sizTx,sizTy)
307          _RS frcFldRS(sizI1:sizI2,sizJ1:sizJ2,sizF,sizTx,sizTy)
308        _RL scaleFact        _RL scaleFact
309        INTEGER power        INTEGER power
310          INTEGER arrType
311        LOGICAL useFract        LOGICAL useFract
312        INTEGER iRun, jRun, k, bi, bj        INTEGER iRun, jRun, k, bi, bj
313        INTEGER myThid        INTEGER myThid
# Line 311  C---+----1----+----2----+----3----+----4 Line 325  C---+----1----+----2----+----3----+----4
325    
326        IF ( useFract .AND. power.EQ.2 ) THEN        IF ( useFract .AND. power.EQ.2 ) THEN
327         l = MIN(k,sizF)         l = MIN(k,sizF)
328         DO j = 1,jRun  
329          DO i = 1,iRun         IF ( arrType.EQ.0 ) THEN
330            DO j = 1,jRun
331             DO i = 1,iRun
332              cumFld(i,j) = cumFld(i,j)
333         &                + tmpFact*inpFldRL(i,j,k,bi,bj)
334         &                         *inpFldRL(i,j,k,bi,bj)
335         &                         *frcFldRL(i,j,l,bi,bj)
336             ENDDO
337            ENDDO
338           ELSEIF ( arrType.EQ.1 ) THEN
339            DO j = 1,jRun
340             DO i = 1,iRun
341            cumFld(i,j) = cumFld(i,j)            cumFld(i,j) = cumFld(i,j)
342       &                + tmpFact*inpFld(i,j,k,bi,bj)       &                + tmpFact*inpFldRL(i,j,k,bi,bj)
343       &                         *inpFld(i,j,k,bi,bj)       &                         *inpFldRL(i,j,k,bi,bj)
344       &                         *frcFld(i,j,l,bi,bj)       &                         *frcFldRS(i,j,l,bi,bj)
345             ENDDO
346          ENDDO          ENDDO
347         ENDDO         ELSEIF ( arrType.EQ.2 ) THEN
348            DO j = 1,jRun
349             DO i = 1,iRun
350              cumFld(i,j) = cumFld(i,j)
351         &                + tmpFact*inpFldRS(i,j,k,bi,bj)
352         &                         *inpFldRS(i,j,k,bi,bj)
353         &                         *frcFldRL(i,j,l,bi,bj)
354             ENDDO
355            ENDDO
356           ELSEIF ( arrType.EQ.3 ) THEN
357            DO j = 1,jRun
358             DO i = 1,iRun
359              cumFld(i,j) = cumFld(i,j)
360         &                + tmpFact*inpFldRS(i,j,k,bi,bj)
361         &                         *inpFldRS(i,j,k,bi,bj)
362         &                         *frcFldRS(i,j,l,bi,bj)
363             ENDDO
364            ENDDO
365           ELSE
366            STOP 'DIAGNOSTICS_CUMULATE: invalid arrType'
367           ENDIF
368    
369        ELSEIF ( useFract ) THEN        ELSEIF ( useFract ) THEN
370         l = MIN(k,sizF)         l = MIN(k,sizF)
371         DO j = 1,jRun  
372          DO i = 1,iRun         IF ( arrType.EQ.0 ) THEN
373            DO j = 1,jRun
374             DO i = 1,iRun
375              cumFld(i,j) = cumFld(i,j)
376         &                + tmpFact*inpFldRL(i,j,k,bi,bj)
377         &                         *frcFldRL(i,j,l,bi,bj)
378             ENDDO
379            ENDDO
380           ELSEIF ( arrType.EQ.1 ) THEN
381            DO j = 1,jRun
382             DO i = 1,iRun
383            cumFld(i,j) = cumFld(i,j)            cumFld(i,j) = cumFld(i,j)
384       &                + tmpFact*inpFld(i,j,k,bi,bj)       &                + tmpFact*inpFldRL(i,j,k,bi,bj)
385       &                         *frcFld(i,j,l,bi,bj)       &                         *frcFldRS(i,j,l,bi,bj)
386             ENDDO
387          ENDDO          ENDDO
388         ENDDO         ELSEIF ( arrType.EQ.2 ) THEN
389            DO j = 1,jRun
390             DO i = 1,iRun
391              cumFld(i,j) = cumFld(i,j)
392         &                + tmpFact*inpFldRS(i,j,k,bi,bj)
393         &                         *frcFldRL(i,j,l,bi,bj)
394             ENDDO
395            ENDDO
396           ELSEIF ( arrType.EQ.3 ) THEN
397            DO j = 1,jRun
398             DO i = 1,iRun
399              cumFld(i,j) = cumFld(i,j)
400         &                + tmpFact*inpFldRS(i,j,k,bi,bj)
401         &                         *frcFldRS(i,j,l,bi,bj)
402             ENDDO
403            ENDDO
404           ELSE
405            STOP 'DIAGNOSTICS_CUMULATE: invalid arrType'
406           ENDIF
407    
408        ELSEIF ( power.EQ.2 ) THEN        ELSEIF ( power.EQ.2 ) THEN
409         DO j = 1,jRun  
410          DO i = 1,iRun         IF ( arrType.LE.1 ) THEN
411            DO j = 1,jRun
412             DO i = 1,iRun
413              cumFld(i,j) = cumFld(i,j)
414         &                + tmpFact*inpFldRL(i,j,k,bi,bj)
415         &                         *inpFldRL(i,j,k,bi,bj)
416             ENDDO
417            ENDDO
418           ELSEIF ( arrType.LE.3 ) THEN
419            DO j = 1,jRun
420             DO i = 1,iRun
421            cumFld(i,j) = cumFld(i,j)            cumFld(i,j) = cumFld(i,j)
422       &                + tmpFact*inpFld(i,j,k,bi,bj)       &                + tmpFact*inpFldRS(i,j,k,bi,bj)
423       &                         *inpFld(i,j,k,bi,bj)       &                         *inpFldRS(i,j,k,bi,bj)
424             ENDDO
425          ENDDO          ENDDO
426         ENDDO         ELSE
427            STOP 'DIAGNOSTICS_CUMULATE: invalid arrType'
428           ENDIF
429    
430        ELSE        ELSE
431         DO j = 1,jRun  
432          DO i = 1,iRun         IF ( arrType.LE.1 ) THEN
433            DO j = 1,jRun
434             DO i = 1,iRun
435  C- jmc: try with fixed ranges, that are known at compiling stage  C- jmc: try with fixed ranges, that are known at compiling stage
436  C        (might produce a better cash optimisation ?)  C        (might produce a better cash optimisation ?)
437  c      DO j = 1,sNy  c       DO j = 1,sNy
438  c       DO i = 1,sNx  c        DO i = 1,sNx
439              cumFld(i,j) = cumFld(i,j)
440         &                + tmpFact*inpFldRL(i,j,k,bi,bj)
441             ENDDO
442            ENDDO
443           ELSEIF ( arrType.LE.3 ) THEN
444            DO j = 1,jRun
445             DO i = 1,iRun
446            cumFld(i,j) = cumFld(i,j)            cumFld(i,j) = cumFld(i,j)
447       &                + tmpFact*inpFld(i,j,k,bi,bj)       &                + tmpFact*inpFldRS(i,j,k,bi,bj)
448             ENDDO
449          ENDDO          ENDDO
450         ENDDO         ELSE
451            STOP 'DIAGNOSTICS_CUMULATE: invalid arrType'
452           ENDIF
453    
454        ENDIF        ENDIF
455    
456        RETURN        RETURN
Legend:
Removed from v.1.5  
changed lines
  Added in v.1.6
  ViewVC Help
Powered by ViewVC 1.1.22