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

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

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

revision 1.2 by jmc, Sun Dec 19 20:27:42 2004 UTC revision 1.7 by jmc, Thu May 19 02:29:38 2005 UTC
# Line 6  C $Name$ Line 6  C $Name$
6  CBOP  CBOP
7  C     !ROUTINE: DIAGNOSTICS_FILL  C     !ROUTINE: DIAGNOSTICS_FILL
8  C     !INTERFACE:  C     !INTERFACE:
9        SUBROUTINE DIAGNOSTICS_FILL (inpFld, chardiag,        SUBROUTINE DIAGNOSTICS_FILL (inpfld, chardiag,
10       I                kLev, nLevs, bibjFlg, biArg, bjArg, myThid)       I                kLev, nLevs, bibjflg, biArg, bjArg, myThid)
11    
12  C     !DESCRIPTION:  C     !DESCRIPTION:
13  C***********************************************************************  C***********************************************************************
14  C   Wrapper routine to increment the diagnostics array with a field  C   Wrapper routine to increment the diagnostics arrays with a field
15  C***********************************************************************  C***********************************************************************
16  C     !USES:  C     !USES:
17        IMPLICIT NONE        IMPLICIT NONE
# Line 26  C     !INPUT PARAMETERS: Line 26  C     !INPUT PARAMETERS:
26  C***********************************************************************  C***********************************************************************
27  C  Arguments Description  C  Arguments Description
28  C  ----------------------  C  ----------------------
29  C     inpFld ..... Field to increment diagnostics array  C     inpfld ..... Field to increment diagnostics array
30  C     chardiag ... Character expression for diag to fill  C     chardiag ... Character expression for diag to fill
31  C     kLev   ..... Integer flag for vertical levels:  C     kLev   ..... Integer flag for vertical levels:
32  C                  0 indicates multiple levels incremented in qdiag  C                  > 0 (any integer): WHICH single level to increment in qdiag.
33  C                  non-0 (any integer) - WHICH single level to increment.  C                  0,-1 to increment "nLevs" levels in qdiag,
34  C                  negative INTEGER - the input data array is single-leveled  C                  0 : fill-in in the same order as the input array
35  C                  positive INTEGER - the input data array is multi-leveled  C                  -1: fill-in in reverse order.
36  C     nLevs ...... indicates Number of levels of the input field array:  C     nLevs ...... indicates Number of levels of the input field array
37  C                  |nLevs| = 3rd dimension size of inpFld array (=1 if kLev <0)  C                  (whether to fill-in all the levels (kLev<1) or just one (kLev>0))
38  C                  positive: fill in "nLevs" levels in the same order as  C     bibjflg .... Integer flag to indicate instructions for bi bj loop
 C                            the input array  
 C                  negative: fill in -nLevs levels in reverse order.  
 C     bibjFlg .... Integer flag to indicate instructions for bi bj loop  
39  C                  0 indicates that the bi-bj loop must be done here  C                  0 indicates that the bi-bj loop must be done here
40  C                  1 indicates that the bi-bj loop is done OUTSIDE  C                  1 indicates that the bi-bj loop is done OUTSIDE
41  C                  2 indicates that the bi-bj loop is done OUTSIDE  C                  2 indicates that the bi-bj loop is done OUTSIDE
# Line 46  C                     AND that we have b Line 43  C                     AND that we have b
43  C                  3 indicates that the bi-bj loop is done OUTSIDE  C                  3 indicates that the bi-bj loop is done OUTSIDE
44  C                     AND that we have been sent a local array  C                     AND that we have been sent a local array
45  C                     AND that the array has no overlap region (interior only)  C                     AND that the array has no overlap region (interior only)
46  C     biArg ...... X-direction tile number - used for bibjFlg=1-3  C                  NOTE - bibjflg can be NEGATIVE to indicate not to increment counter
47  C     bjArg ...... Y-direction tile number - used for bibjFlg=1-3  C     biArg ...... X-direction tile number - used for bibjflg=1-3
48    C     bjArg ...... Y-direction tile number - used for bibjflg=1-3
49  C     myThid     ::  my thread Id number  C     myThid     ::  my thread Id number
50  C***********************************************************************  C***********************************************************************
51  C                  NOTE: User beware! If a local (1 tile only) array  C                  NOTE: User beware! If a local (1 tile only) array
52  C                        is sent here, bibjFlg MUST NOT be set to 0  C                        is sent here, bibjflg MUST NOT be set to 0
53  C                        or there will be out of bounds problems!  C                        or there will be out of bounds problems!
54  C***********************************************************************  C***********************************************************************
55        _RL inpFld(*)        _RL inpfld(*)
56        CHARACTER*8 chardiag        CHARACTER*8 chardiag
57        INTEGER kLev, nLevs, bibjFlg, biArg, bjArg        INTEGER kLev, nLevs, bibjflg, biArg, bjArg
58        INTEGER myThid        INTEGER myThid
59  CEOP  CEOP
60    
61  C     !LOCAL VARIABLES:  C     !LOCAL VARIABLES:
62  C ===============  C ===============
63        INTEGER m, n        INTEGER m, n, j
64        INTEGER ndiagnum, ipointer        INTEGER ndiagnum, ipointer, iSp, jSd
65        INTEGER sizI1,sizI2,sizJ1,sizJ2  c     INTEGER region2fill(0:nRegions)
       INTEGER sizK,sizTx,sizTy  
       INTEGER iRun, jRun, kl, bi, bj  
       INTEGER k, kFirst, kLast  
       INTEGER kd, kd0, ksgn, kStore  
       CHARACTER*8 parms1  
       CHARACTER*(MAX_LEN_MBUF) msgBuf  
66    
67    C--   2D/3D Diagnostics :
68  C Run through list of active diagnostics to make sure  C Run through list of active diagnostics to make sure
69  C we are trying to fill a valid diagnostic  C we are trying to fill a valid diagnostic
70    
# Line 86  C we are trying to fill a valid diagnost Line 79  C we are trying to fill a valid diagnost
79         ENDDO         ENDDO
80        ENDDO        ENDDO
81    
82  C If-sequence to see if we are a valid and an active diagnostic  C if we are a valid and an active diagnostic, do the filling:
83          IF ( ipointer.NE.0 ) THEN
84        IF ( ndiagnum.NE.0 .AND. ipointer.NE.0 ) THEN          CALL DIAGNOSTICS_FILL_FIELD( inpfld, ndiagnum, ipointer,
85         I                kLev, nLevs, bibjflg, biArg, bjArg, myThid )
 C Increment the counter for the diagnostic (if we are at bi=bj=myThid=1)  
        _BEGIN_MASTER(myThid)  
         IF ((biArg.EQ.1).AND.(bjArg.EQ.1).AND.(ABS(kLev).LE.1) )  
      &                     ndiag(ndiagnum) = ndiag(ndiagnum) + 1  
        _END_MASTER(myThid)  
   
 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  
   
 C-      select range for 1rst & 2nd indices to accumulate  
 C         depending on variable location on C-grid,  
         parms1 = gdiag(ndiagnum)(1:8)  
         IF ( parms1(2:2).EQ.'M' ) THEN  
          iRun = sNx  
          jRun = sNy  
         ELSEIF ( parms1(2:2).EQ.'U' ) THEN  
          iRun = sNx+1  
          jRun = sNy  
         ELSEIF ( parms1(2:2).EQ.'V' ) THEN  
          iRun = sNx  
          jRun = sNy+1  
         ELSEIF ( parms1(2:2).EQ.'Z' ) THEN  
          iRun = sNx+1  
          jRun = sNy+1  
         ELSE  
          iRun = sNx  
          jRun = sNy  
         ENDIF  
   
 C-      Dimension of the input array:  
         IF (bibjFlg.EQ.3) THEN  
           sizI1 = 1  
           sizI2 = sNx  
           sizJ1 = 1  
           sizJ2 = sNy  
           iRun = sNx  
           jRun = sNy  
         ELSE  
           sizI1 = 1-OLx  
           sizI2 = sNx+OLx  
           sizJ1 = 1-OLy  
           sizJ2 = sNy+OLy  
         ENDIF  
         IF (bibjFlg.GE.2) THEN  
          sizTx = 1  
          sizTy = 1  
         ELSE  
          sizTx = nSx  
          sizTy = nSy  
         ENDIF  
         IF (kLev.GE.0) THEN  
          sizK = ABS(nLevs)  
         ELSE  
          sizK = 1  
         ENDIF  
 C-      Which part of inpFld to add : kl = 3rd index,  
 C         and do the loop >> do k=kFirst,kLast ; kl = min(k,sizK) <<  
         IF (kLev.EQ.0) THEN  
           kFirst = 1  
           kLast  = sizK  
         ELSE  
           kFirst = ABS(kLev)  
           kLast  = ABS(kLev)  
         ENDIF  
 C-      Which part of qdiag to update: kd = 3rd index,  
 C         and do the loop >> do k=kFirst,kLast ; kd = kd0 + k*ksgn <<  
         IF ( nLevs.GT.0 ) THEN  
           ksgn = 1  
           kd0 = ipointer - 1  
         ELSE  
           ksgn = -1  
           kd0 = ipointer + sizK  
         ENDIF  
   
 C-      Check for consistency with Nb of levels reserved in storage array  
         kStore = kd0 + MAX(ksgn*kFirst,ksgn*kLast) - ipointer + 1  
         IF ( kStore.GT.kdiag(ndiagnum) ) THEN  
          _BEGIN_MASTER(myThid)  
           WRITE(msgBuf,'(2A,I3,A)') 'DIAGNOSTICS_FILL: ',  
      &     'exceed Nb of levels(=',kdiag(ndiagnum),' ) reserved '  
           CALL PRINT_ERROR( msgBuf , myThid )  
           WRITE(msgBuf,'(2A,I4,2A)') 'DIAGNOSTICS_FILL: ',  
      &     'for Diagnostics #', ndiagnum, ' : ', chardiag  
           CALL PRINT_ERROR( msgBuf , myThid )  
           WRITE(msgBuf,'(2A,2I4,I3)') 'calling DIAGNOSTICS_FILL ',  
      I     'with kLev,nLevs,bibjFlg=', kLev,nLevs,bibjFlg  
           CALL PRINT_ERROR( msgBuf , myThid )  
           WRITE(msgBuf,'(2A,I6,A)') 'DIAGNOSTICS_FILL: ',  
      I     '==> trying to store up to ', kStore, ' levels'  
           CALL PRINT_ERROR( msgBuf , myThid )  
           STOP 'ABNORMAL END: S/R DIAGNOSTICS_FILL'  
          _END_MASTER(myThid)  
         ENDIF  
   
         IF (bibjFlg.EQ.0) THEN  
           
          DO bj=myByLo(myThid), myByHi(myThid)  
           DO bi=myBxLo(myThid), myBxHi(myThid)  
            DO k = kFirst,kLast  
             kd = kd0 + ksgn*k  
             kl = MIN(k,sizK)  
             CALL DIAGNOSTICS_DO_FILL(  
      U                  qdiag(1-OLx,1-OLy,kd,bi,bj),  
      I                  inpFld,  
      I                  sizI1,sizI2,sizJ1,sizJ2,sizK,sizTx,sizTy,  
      I                  iRun,jRun,kl,bi,bj,  
      I                  myThid)  
            ENDDO  
           ENDDO  
          ENDDO  
         ELSE  
           bi = MIN(biArg,sizTx)  
           bj = MIN(bjArg,sizTy)  
           DO k = kFirst,kLast  
             kd = kd0 + ksgn*k  
             kl = MIN(k,sizK)  
             CALL DIAGNOSTICS_DO_FILL(  
      U                  qdiag(1-OLx,1-OLy,kd,biArg,bjArg),  
      I                  inpFld,  
      I                  sizI1,sizI2,sizJ1,sizJ2,sizK,sizTx,sizTy,  
      I                  iRun,jRun,kl,bi,bj,  
      I                  myThid)  
           ENDDO  
         ENDIF  
   
 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  
 c     ELSE  
 c     IF (myThid.EQ.1) WRITE(6,1000) chardiag  
   
86        ENDIF        ENDIF
87    
  1000 format(' ',' Warning: Trying to write to diagnostic ',a8,  
      &        ' But it is not a valid (or active) name ')  
       RETURN  
       END  
   
88  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
89    
 CBOP  
 C     !ROUTINE: DIAGNOSTICS_DO_FILL  
 C     !INTERFACE:  
       SUBROUTINE DIAGNOSTICS_DO_FILL(  
      U                  cumFld,  
      I                  inpFld,  
      I                  sizI1,sizI2,sizJ1,sizJ2,sizK,sizTx,sizTy,  
      I                  iRun,jRun,k,bi,bj,  
      I                  myThid)  
   
 C     !DESCRIPTION:  
 C     Update array cumFld  
 C     by adding content of input field array inpFld  
 C     over the range [1:iRun],[1:jRun]  
   
 C     !USES:  
       IMPLICIT NONE  
   
 #include "EEPARAMS.h"  
 #include "SIZE.h"  
   
 C     !INPUT/OUTPUT PARAMETERS:  
 C     == Routine Arguments ==  
 C     cumFld      :: cumulative array (updated)  
 C     inpFld      :: input field array to add to cumFld  
 C     sizI1,sizI2 :: size of inpFld array: 1rst index range (min,max)  
 C     sizJ1,sizJ2 :: size of inpFld array: 2nd  index range (min,max)  
 C     sizK        :: size of inpFld array: 3rd  dimension  
 C     sizTx,sizTy :: size of inpFld array: tile dimensions  
 C     iRun,jRun   :: range of 1rst & 2nd index  
 C     k,bi,bj     :: level and tile indices of inFld array  
 C                    to add to cumFld array  
 C     myThid      :: my Thread Id number  
       _RL cumFld(1-OLx:sNx+OLx,1-OLy:sNy+OLy)  
       INTEGER sizI1,sizI2,sizJ1,sizJ2  
       INTEGER sizK,sizTx,sizTy  
       _RL inpFld(sizI1:sizI2,sizJ1:sizJ2,sizK,sizTx,sizTy)  
       INTEGER iRun, jRun, k, bi, bj  
       INTEGER myThid  
 CEOP  
   
 C     !LOCAL VARIABLES:  
 C     i,j    :: loop indices  
       INTEGER i, j  
   
 c     DO j = 1,jRun  
 c      DO i = 1,iRun  
 C- jmc: try with fixed ranges, that are known at compiling stage  
 C        (might produce a better cash optimisation ?)  
       DO j = 1,sNy  
        DO i = 1,sNx  
         cumFld(i,j) = cumFld(i,j) + inpFld(i,j,k,bi,bj)  
        ENDDO  
       ENDDO  
   
90        RETURN        RETURN
91        END        END
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.7
  ViewVC Help
Powered by ViewVC 1.1.22