/[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.1 by jmc, Mon Dec 13 21:55:48 2004 UTC revision 1.2 by jmc, Sun Dec 19 20:27:42 2004 UTC
# Line 3  C $Name$ Line 3  C $Name$
3    
4  #include "DIAG_OPTIONS.h"  #include "DIAG_OPTIONS.h"
5    
6        subroutine diagnostics_fill (arrayin, chardiag,  CBOP
7       .                       levflg, nlevs, bibjflg, bi, bj, myThid)  C     !ROUTINE: DIAGNOSTICS_FILL
8    C     !INTERFACE:
9          SUBROUTINE DIAGNOSTICS_FILL (inpFld, chardiag,
10         I                kLev, nLevs, bibjFlg, biArg, bjArg, myThid)
11    
12    C     !DESCRIPTION:
13  C***********************************************************************  C***********************************************************************
 C  Purpose  
 C  -------  
14  C   Wrapper routine to increment the diagnostics array with a field  C   Wrapper routine to increment the diagnostics array with a field
15  C  C***********************************************************************
16    C     !USES:
17          IMPLICIT NONE
18    
19    C     == Global variables ===
20    #include "EEPARAMS.h"
21    #include "SIZE.h"
22    #include "DIAGNOSTICS_SIZE.h"
23    #include "DIAGNOSTICS.h"
24    
25    C     !INPUT PARAMETERS:
26    C***********************************************************************
27  C  Arguments Description  C  Arguments Description
28  C  ----------------------  C  ----------------------
29  C     arrayin .... 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     levflg ..... Integer flag for vertical levels:  C     kLev   ..... Integer flag for vertical levels:
32  C                  0 indicates multiple levels incremented in qdiag  C                  0 indicates multiple levels incremented in qdiag
33  C                  non-0 (any integer) - WHICH single level to increment.  C                  non-0 (any integer) - WHICH single level to increment.
34  C                  negative integer - the input data array is single-leveled  C                  negative INTEGER - the input data array is single-leveled
35  C                  positive integer - the input data array is multi-leveled  C                  positive INTEGER - the input data array is multi-leveled
36  C     nlevs ...... indicates Number of levels to be filled (1 if levflg <> 0)  C     nLevs ...... indicates Number of levels of the input field array:
37  C                  positive: fill in "nlevs" levels in the same order as  C                  |nLevs| = 3rd dimension size of inpFld array (=1 if kLev <0)
38    C                  positive: fill in "nLevs" levels in the same order as
39  C                            the input array  C                            the input array
40  C                  negative: fill in -nlevs levels in reverse order.  C                  negative: fill in -nLevs levels in reverse order.
41  C     bibjflg .... Integer flag to indicate instructions for bi bj loop  C     bibjFlg .... Integer flag to indicate instructions for bi bj loop
42  C                  0 indicates that the bi-bj loop must be done here  C                  0 indicates that the bi-bj loop must be done here
43  C                  1 indicates that the bi-bj loop is done OUTSIDE  C                  1 indicates that the bi-bj loop is done OUTSIDE
44  C                  2 indicates that the bi-bj loop is done OUTSIDE  C                  2 indicates that the bi-bj loop is done OUTSIDE
# Line 31  C                     AND that we have b Line 46  C                     AND that we have b
46  C                  3 indicates that the bi-bj loop is done OUTSIDE  C                  3 indicates that the bi-bj loop is done OUTSIDE
47  C                     AND that we have been sent a local array  C                     AND that we have been sent a local array
48  C                     AND that the array has no overlap region (interior only)  C                     AND that the array has no overlap region (interior only)
49  C     bi ......... X-direction process(or) number - used for bibjflg=1-3  C     biArg ...... X-direction tile number - used for bibjFlg=1-3
50  C     bj ......... Y-direction process(or) number - used for bibjflg=1-3  C     bjArg ...... Y-direction tile number - used for bibjFlg=1-3
51  C     myThid     ::  my thread Id number  C     myThid     ::  my thread Id number
52  C***********************************************************************  C***********************************************************************
53  C                  NOTE: User beware! If a local (1 tile only) array  C                  NOTE: User beware! If a local (1 tile only) array
54  C                        is sent here, bibjflg MUST NOT be set to 0  C                        is sent here, bibjFlg MUST NOT be set to 0
55  C                        or there will be out of bounds problems!  C                        or there will be out of bounds problems!
56  C***********************************************************************  C***********************************************************************
57         implicit none        _RL inpFld(*)
58  #include "EEPARAMS.h"        CHARACTER*8 chardiag
59  #include "SIZE.h"        INTEGER kLev, nLevs, bibjFlg, biArg, bjArg
60  #include "DIAGNOSTICS_SIZE.h"        INTEGER myThid
61  #include "DIAGNOSTICS.h"  CEOP
62    
63        integer myThid,levflg,nlevs,bibjflg,bi,bj  C     !LOCAL VARIABLES:
64        character *8 chardiag  C ===============
65        _RL arrayin(*)        INTEGER m, n
66          INTEGER ndiagnum, ipointer
67  c Local variables        INTEGER sizI1,sizI2,sizJ1,sizJ2
68  c ===============        INTEGER sizK,sizTx,sizTy
69        integer i, j, m, n        INTEGER iRun, jRun, kl, bi, bj
70        integer ndiagnum, bihere, bjhere, levhere, ipointer        INTEGER k, kFirst, kLast
71        _RL array(1-OLx:sNx+OLx,1-OLy:sNy+OLy)        INTEGER kd, kd0, ksgn, kStore
72        _RL arrayloc(sNx,sNy)        CHARACTER*8 parms1
73        integer irun,jrun,krun,birun,bjrun        CHARACTER*(MAX_LEN_MBUF) msgBuf
       integer level  
74    
75  C Run through list of active diagnostics to make sure  C Run through list of active diagnostics to make sure
76  C we are trying to fill a valid diagnostic  C we are trying to fill a valid diagnostic
# Line 67  C we are trying to fill a valid diagnost Line 81  C we are trying to fill a valid diagnost
81         DO m=1,nActive(n)         DO m=1,nActive(n)
82          IF ( chardiag.EQ.flds(m,n) ) THEN          IF ( chardiag.EQ.flds(m,n) ) THEN
83           ndiagnum = jdiag(m,n)           ndiagnum = jdiag(m,n)
84           ipointer = idiag(ndiagnum)           IF (ndiag(ndiagnum).GE.0) ipointer = idiag(ndiagnum)
85          ENDIF          ENDIF
86         ENDDO         ENDDO
87        ENDDO        ENDDO
88    
89  C If-sequence to see if we are a valid and an active diagnostic  C If-sequence to see if we are a valid and an active diagnostic
90    
91        IF ( ndiagnum.ne.0 .and. ipointer.ne.0 ) THEN        IF ( ndiagnum.NE.0 .AND. ipointer.NE.0 ) THEN
92    
93  C Increment the counter for the diagnostic (if we are at bi=bj=1)  C Increment the counter for the diagnostic (if we are at bi=bj=myThid=1)
94        _BEGIN_MASTER(myThid)         _BEGIN_MASTER(myThid)
95        if ((bi.eq.1).and.(bj.eq.1).and.(abs(levflg).le.1) )          IF ((biArg.EQ.1).AND.(bjArg.EQ.1).AND.(ABS(kLev).LE.1) )
96       .                     ndiag(ndiagnum) = ndiag(ndiagnum) + 1       &                     ndiag(ndiagnum) = ndiag(ndiagnum) + 1
97        _END_MASTER(myThid)         _END_MASTER(myThid)
   
 C   Check to see if we need to do a bi-bj loop here  
98    
99  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
       if(bibjflg.eq.0) then  
        irun = sNx+2*OLx  
        jrun = sNy+2*OLy  
        krun = abs(nlevs)  
        birun = nSx  
        bjrun = nSy  
   
        do bjhere=myByLo(myThid), myByHi(myThid)  
        do bihere=myBxLo(myThid), myBxHi(myThid)  
   
        if(levflg.eq.0)then  
         do levhere = 1,krun  
          level = levhere  
          IF (nlevs.LT.0) level=1-nlevs-levhere  
          call diagnostics_fillit(arrayin,irun,jrun,krun,levhere,  
      .                           birun,bjrun,bihere,bjhere,array,myThid)  
          do j = 1,sNy  
          do i = 1,sNx  
           qdiag(i,j,ipointer+level-1,bihere,bjhere) =  
      .  qdiag(i,j,ipointer+level-1,bihere,bjhere) +  
      .                       array(i,j)  
          enddo  
          enddo  
         enddo  
        elseif(levflg.gt.0)then  
         call diagnostics_fillit(arrayin,irun,jrun,krun,levflg,  
      .                           birun,bjrun,bihere,bjhere,array,myThid)  
         do j = 1,sNy  
         do i = 1,sNx  
          qdiag(i,j,ipointer+levflg-1,bihere,bjhere) =  
      .  qdiag(i,j,ipointer+levflg-1,bihere,bjhere) +  
      .                       array(i,j)  
         enddo  
         enddo  
        else  
         level = -1 * levflg  
         call diagnostics_fillit(arrayin,irun,jrun,1,1,birun,bjrun,  
      .                                       bihere,bjhere,array,myThid)  
         do j = 1,sNy  
         do i = 1,sNx  
          qdiag(i,j,ipointer+level-1,bihere,bjhere) =  
      .  qdiag(i,j,ipointer+level-1,bihere,bjhere) +  
      .                       array(i,j)  
         enddo  
         enddo  
        endif  
100    
101         enddo  C-      select range for 1rst & 2nd indices to accumulate
102         enddo  C         depending on variable location on C-grid,
103            parms1 = gdiag(ndiagnum)(1:8)
104            IF ( parms1(2:2).EQ.'M' ) THEN
105             iRun = sNx
106             jRun = sNy
107            ELSEIF ( parms1(2:2).EQ.'U' ) THEN
108             iRun = sNx+1
109             jRun = sNy
110            ELSEIF ( parms1(2:2).EQ.'V' ) THEN
111             iRun = sNx
112             jRun = sNy+1
113            ELSEIF ( parms1(2:2).EQ.'Z' ) THEN
114             iRun = sNx+1
115             jRun = sNy+1
116            ELSE
117             iRun = sNx
118             jRun = sNy
119            ENDIF
120    
121  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C-      Dimension of the input array:
122        elseif(bibjflg.eq.1) then          IF (bibjFlg.EQ.3) THEN
123         irun = sNx+2*OLx            sizI1 = 1
124         jrun = sNy+2*OLy            sizI2 = sNx
125         krun = abs(nlevs)            sizJ1 = 1
126         birun = nSx            sizJ2 = sNy
127         bjrun = nSy            iRun = sNx
128              jRun = sNy
129         if(levflg.eq.0)then          ELSE
130          do levhere = 1,krun            sizI1 = 1-OLx
131           level = levhere            sizI2 = sNx+OLx
132           IF (nlevs.LT.0) level=1-nlevs-levhere            sizJ1 = 1-OLy
133           call diagnostics_fillit(arrayin,irun,jrun,krun,levhere,            sizJ2 = sNy+OLy
134       .                           birun,bjrun,bi,bj,array,myThid)          ENDIF
135           do j = 1,sNy          IF (bibjFlg.GE.2) THEN
136           do i = 1,sNx           sizTx = 1
137            qdiag(i,j,ipointer+level-1,bi,bj) =           sizTy = 1
138       .  qdiag(i,j,ipointer+level-1,bi,bj) +          ELSE
139       .                       array(i,j)           sizTx = nSx
140           enddo           sizTy = nSy
141           enddo          ENDIF
142          enddo          IF (kLev.GE.0) THEN
143         elseif(levflg.gt.0)then           sizK = ABS(nLevs)
144          call diagnostics_fillit(arrayin,irun,jrun,krun,levflg,          ELSE
145       .                           birun,bjrun,bi,bj,array,myThid)           sizK = 1
146          do j = 1,sNy          ENDIF
147          do i = 1,sNx  C-      Which part of inpFld to add : kl = 3rd index,
148           qdiag(i,j,ipointer+levflg-1,bi,bj) =  C         and do the loop >> do k=kFirst,kLast ; kl = min(k,sizK) <<
149       .  qdiag(i,j,ipointer+levflg-1,bi,bj) + array(i,j)          IF (kLev.EQ.0) THEN
150          enddo            kFirst = 1
151          enddo            kLast  = sizK
152         else          ELSE
153          level = -1 * levflg            kFirst = ABS(kLev)
154          call diagnostics_fillit(arrayin,irun,jrun,1,1,birun,bjrun,            kLast  = ABS(kLev)
155       .                                       bi,bj,array,myThid)          ENDIF
156          do j = 1,sNy  C-      Which part of qdiag to update: kd = 3rd index,
157          do i = 1,sNx  C         and do the loop >> do k=kFirst,kLast ; kd = kd0 + k*ksgn <<
158           qdiag(i,j,ipointer+level-1,bi,bj) =          IF ( nLevs.GT.0 ) THEN
159       .  qdiag(i,j,ipointer+level-1,bi,bj) + array(i,j)            ksgn = 1
160          enddo            kd0 = ipointer - 1
161          enddo          ELSE
162         endif            ksgn = -1
163              kd0 = ipointer + sizK
164            ENDIF
165    
166  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C-      Check for consistency with Nb of levels reserved in storage array
167        elseif(bibjflg.eq.3) then          kStore = kd0 + MAX(ksgn*kFirst,ksgn*kLast) - ipointer + 1
168         irun = sNx          IF ( kStore.GT.kdiag(ndiagnum) ) THEN
169         jrun = sNy           _BEGIN_MASTER(myThid)
170         krun = abs(nlevs)            WRITE(msgBuf,'(2A,I3,A)') 'DIAGNOSTICS_FILL: ',
171         birun = 1       &     'exceed Nb of levels(=',kdiag(ndiagnum),' ) reserved '
172         bjrun = 1            CALL PRINT_ERROR( msgBuf , myThid )
173              WRITE(msgBuf,'(2A,I4,2A)') 'DIAGNOSTICS_FILL: ',
174         if(levflg.eq.0)then       &     'for Diagnostics #', ndiagnum, ' : ', chardiag
175          do levhere = 1,krun            CALL PRINT_ERROR( msgBuf , myThid )
176           level = levhere            WRITE(msgBuf,'(2A,2I4,I3)') 'calling DIAGNOSTICS_FILL ',
177           IF (nlevs.LT.0) level=1-nlevs-levhere       I     'with kLev,nLevs,bibjFlg=', kLev,nLevs,bibjFlg
178           call diagnostics_fillit(arrayin,irun,jrun,krun,levhere,            CALL PRINT_ERROR( msgBuf , myThid )
179       .                           birun,bjrun,1,1,arrayloc,myThid)            WRITE(msgBuf,'(2A,I6,A)') 'DIAGNOSTICS_FILL: ',
180           do j = 1,sNy       I     '==> trying to store up to ', kStore, ' levels'
181           do i = 1,sNx            CALL PRINT_ERROR( msgBuf , myThid )
182            qdiag(i,j,ipointer+level-1,bi,bj) =            STOP 'ABNORMAL END: S/R DIAGNOSTICS_FILL'
183       .  qdiag(i,j,ipointer+level-1,bi,bj) + arrayloc(i,j)           _END_MASTER(myThid)
184           enddo          ENDIF
          enddo  
         enddo  
        elseif(levflg.gt.0)then  
         call diagnostics_fillit(arrayin,irun,jrun,krun,levflg,  
      .                           birun,bjrun,1,1,arrayloc,myThid)  
         do j = 1,sNy  
         do i = 1,sNx  
          qdiag(i,j,ipointer+levflg-1,bi,bj) =  
      .  qdiag(i,j,ipointer+levflg-1,bi,bj) + arrayloc(i,j)  
         enddo  
         enddo  
        else  
         level = -1 * levflg  
         call diagnostics_fillit(arrayin,irun,jrun,1,1,birun,bjrun,  
      .                                       1,1,arrayloc,myThid)  
         do j = 1,sNy  
         do i = 1,sNx  
          qdiag(i,j,ipointer+level-1,bi,bj) =  
      .  qdiag(i,j,ipointer+level-1,bi,bj) + arrayloc(i,j)  
         enddo  
         enddo  
        endif  
185    
186  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|          IF (bibjFlg.EQ.0) THEN
187        elseif(bibjflg.eq.2) then          
188         irun = sNx+2*OLx           DO bj=myByLo(myThid), myByHi(myThid)
189         jrun = sNy+2*OLy            DO bi=myBxLo(myThid), myBxHi(myThid)
190         krun = abs(nlevs)             DO k = kFirst,kLast
191         birun = 1              kd = kd0 + ksgn*k
192         bjrun = 1              kl = MIN(k,sizK)
193                CALL DIAGNOSTICS_DO_FILL(
194         if(levflg.eq.0)then       U                  qdiag(1-OLx,1-OLy,kd,bi,bj),
195          do levhere = 1,krun       I                  inpFld,
196           level = levhere       I                  sizI1,sizI2,sizJ1,sizJ2,sizK,sizTx,sizTy,
197           IF (nlevs.LT.0) level=1-nlevs-levhere       I                  iRun,jRun,kl,bi,bj,
198           call diagnostics_fillit(arrayin,irun,jrun,krun,levhere,       I                  myThid)
199       .                              birun,bjrun,1,1,array,myThid)             ENDDO
200           do j = 1,sNy            ENDDO
201           do i = 1,sNx           ENDDO
202            qdiag(i,j,ipointer+level-1,bi,bj) =          ELSE
203       .  qdiag(i,j,ipointer+level-1,bi,bj) + array(i,j)            bi = MIN(biArg,sizTx)
204           enddo            bj = MIN(bjArg,sizTy)
205           enddo            DO k = kFirst,kLast
206          enddo              kd = kd0 + ksgn*k
207         elseif(levflg.gt.0)then              kl = MIN(k,sizK)
208          call diagnostics_fillit(arrayin,irun,jrun,krun,levflg,              CALL DIAGNOSTICS_DO_FILL(
209       .                              birun,bjrun,1,1,array,myThid)       U                  qdiag(1-OLx,1-OLy,kd,biArg,bjArg),
210          do j = 1,sNy       I                  inpFld,
211          do i = 1,sNx       I                  sizI1,sizI2,sizJ1,sizJ2,sizK,sizTx,sizTy,
212           qdiag(i,j,ipointer+levflg-1,bi,bj) =       I                  iRun,jRun,kl,bi,bj,
213       .  qdiag(i,j,ipointer+levflg-1,bi,bj) + array(i,j)       I                  myThid)
214          enddo            ENDDO
215          enddo          ENDIF
        else  
         level = -1 * levflg  
         call diagnostics_fillit(arrayin,irun,jrun,1,1,birun,bjrun,  
      .                                          1,1,array,myThid)  
         do j = 1,sNy  
         do i = 1,sNx  
          qdiag(i,j,ipointer+level-1,bi,bj) =  
      .  qdiag(i,j,ipointer+level-1,bi,bj) + array(i,j)  
         enddo  
         enddo  
        endif  
216    
217  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
218        endif  c     ELSE
219    c     IF (myThid.EQ.1) WRITE(6,1000) chardiag
       ELSE  
   
 C     if (myThid.eq.1) write(6,1000) chardiag  
220    
221        ENDIF        ENDIF
222    
223   1000 format(' ',' Warning: Trying to write to diagnostic ',a8,   1000 format(' ',' Warning: Trying to write to diagnostic ',a8,
224       .        ' But it is not a valid (or active) name ')       &        ' But it is not a valid (or active) name ')
225        return        RETURN
226        end        END
227    
228  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
229    
230        subroutine diagnostics_fillit(  CBOP
231       I                  arrayin,irun,jrun,krun,klevf,birun,bjrun,bi,bj,  C     !ROUTINE: DIAGNOSTICS_DO_FILL
232       O                  arrayout,  C     !INTERFACE:
233          SUBROUTINE DIAGNOSTICS_DO_FILL(
234         U                  cumFld,
235         I                  inpFld,
236         I                  sizI1,sizI2,sizJ1,sizJ2,sizK,sizTx,sizTy,
237         I                  iRun,jRun,k,bi,bj,
238       I                  myThid)       I                  myThid)
239    
240        implicit none  C     !DESCRIPTION:
241    C     Update array cumFld
242    C     by adding content of input field array inpFld
243    C     over the range [1:iRun],[1:jRun]
244    
245    C     !USES:
246          IMPLICIT NONE
247    
248  #include "EEPARAMS.h"  #include "EEPARAMS.h"
249    #include "SIZE.h"
250    
251        integer irun, jrun, krun, klevf, birun, bjrun, bi, bj  C     !INPUT/OUTPUT PARAMETERS:
252        _RL arrayin(irun,jrun,krun,birun,bjrun)  C     == Routine Arguments ==
253        _RL arrayout(irun,jrun)  C     cumFld      :: cumulative array (updated)
254        integer myThid  C     inpFld      :: input field array to add to cumFld
255    C     sizI1,sizI2 :: size of inpFld array: 1rst index range (min,max)
256        integer i, j  C     sizJ1,sizJ2 :: size of inpFld array: 2nd  index range (min,max)
257    C     sizK        :: size of inpFld array: 3rd  dimension
258        do j = 1,jrun  C     sizTx,sizTy :: size of inpFld array: tile dimensions
259         do i = 1,irun  C     iRun,jRun   :: range of 1rst & 2nd index
260          arrayout(i,j) = arrayin(i,j,klevf,bi,bj)  C     k,bi,bj     :: level and tile indices of inFld array
261         enddo  C                    to add to cumFld array
262        enddo  C     myThid      :: my Thread Id number
263          _RL cumFld(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
264          INTEGER sizI1,sizI2,sizJ1,sizJ2
265          INTEGER sizK,sizTx,sizTy
266          _RL inpFld(sizI1:sizI2,sizJ1:sizJ2,sizK,sizTx,sizTy)
267          INTEGER iRun, jRun, k, bi, bj
268          INTEGER myThid
269    CEOP
270    
271    C     !LOCAL VARIABLES:
272    C     i,j    :: loop indices
273          INTEGER i, j
274    
275    c     DO j = 1,jRun
276    c      DO i = 1,iRun
277    C- jmc: try with fixed ranges, that are known at compiling stage
278    C        (might produce a better cash optimisation ?)
279          DO j = 1,sNy
280           DO i = 1,sNx
281            cumFld(i,j) = cumFld(i,j) + inpFld(i,j,k,bi,bj)
282           ENDDO
283          ENDDO
284    
285        return        RETURN
286        end        END
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2
  ViewVC Help
Powered by ViewVC 1.1.22