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

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

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

revision 1.5 by molod, Wed Feb 23 16:01:54 2005 UTC revision 1.8 by jmc, Tue Feb 5 15:31:19 2008 UTC
# Line 7  CBOP Line 7  CBOP
7  C     !ROUTINE: DIAG_VEGTILE_FILL  C     !ROUTINE: DIAG_VEGTILE_FILL
8  C     !INTERFACE:  C     !INTERFACE:
9        SUBROUTINE DIAG_VEGTILE_FILL (field,indx,chfr,ib,numpts,npeice,        SUBROUTINE DIAG_VEGTILE_FILL (field,indx,chfr,ib,numpts,npeice,
10       . check, chardiag, kLev, nLevs, bi, bj, myThid)       . check, chardiag, kLev, nLevs, bi, bj, myThid)
11  C     !DESCRIPTION:  C     !DESCRIPTION:
12  C***********************************************************************  C***********************************************************************
13  C Increment the diagnostics array with a vegetation tile space field  C Increment the diagnostics array with a vegetation tile space field
# Line 36  C   chardiag ... Character expression fo Line 36  C   chardiag ... Character expression fo
36  C   kLev   ..... Integer flag for vertical levels:  C   kLev   ..... Integer flag for vertical levels:
37  C                > 0 (any integer): WHICH single level to increment  C                > 0 (any integer): WHICH single level to increment
38  C                0,-1 to increment "nLevs" levels in qdiag:  C                0,-1 to increment "nLevs" levels in qdiag:
39  C                 0 : fill-in in the same order as the input array  C                 0 : fill-in in the same order as the input array
40  C                -1 : fill-in in reverse order.  C                -1 : fill-in in reverse order.
41  C   nLevs ...... indicates Number of levels of the input field array  C   nLevs ...... indicates Number of levels of the input field array
42  C   bi    ...... X-direction tile number  C   bi    ...... X-direction tile number
# Line 59  CEOP Line 59  CEOP
59    
60  C     !LOCAL VARIABLES:  C     !LOCAL VARIABLES:
61  C ===============  C ===============
62        INTEGER m, n        INTEGER m, n
63        INTEGER ndiagnum, ipointer        INTEGER ndiagnum, ipointer
64        INTEGER k, kFirst, kLast        INTEGER k, kFirst, kLast
65        INTEGER kd, kd0, ksgn, kStore        INTEGER kd, kd0, ksgn, kStore
66        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
67        integer i,offset,Lena,newindx,jindx        integer i,offset,Lena,newindx,jindx
68        _RL undef,getcon        _RL undef,getcon
69          INTEGER iSp, ndId, j,l
70          INTEGER region2fill(0:nRegions)
71          _RL     scaleFact
72          _RL     gridField(sNx*sNy,nlevs), gridFrac(sNx*sNy)
73    
74  C Run through list of active diagnostics to make sure  C Run through list of active diagnostics to make sure
75  C we are trying to fill a valid diagnostic  C we are trying to fill a valid diagnostic
# Line 74  C we are trying to fill a valid diagnost Line 78  C we are trying to fill a valid diagnost
78        ipointer = 0        ipointer = 0
79        DO n=1,nlists        DO n=1,nlists
80         DO m=1,nActive(n)         DO m=1,nActive(n)
81          IF ( chardiag.EQ.flds(m,n) ) THEN          IF ( chardiag.EQ.flds(m,n) .AND. idiag(m,n).GT.0 ) THEN
82           ndiagnum = jdiag(m,n)           ndiagnum = jdiag(m,n)
83           IF (ndiag(ndiagnum).GE.0) ipointer = idiag(ndiagnum)           ipointer = idiag(m,n)
84          ENDIF           IF ( ndiagnum.NE.0 .AND. ndiag(ipointer,1,1).GE.0 ) THEN
85         ENDDO  C--   do the filling: start here:
86        ENDDO  
87           IF ( (ABS(kLev).LE.1) .AND. (npeice.eq.1) ) THEN
88  C If-sequence to see if we are a valid and an active diagnostic  C Increment the counter for the diagnostic
89             ndiag(ipointer,bi,bj) = ndiag(ipointer,bi,bj) + 1
90        IF ( ndiagnum.NE.0 .AND. ipointer.NE.0 ) THEN         ENDIF
   
 C Increment the counter for the diagnostic (if we are at bi=bj=myThid=1)  
        _BEGIN_MASTER(myThid)  
        IF((bi.EQ.1).AND.(bj.EQ.1).AND.(ABS(kLev).LE.1)  
      .         .AND.(npeice.eq.1))  
      .                     ndiag(ndiagnum) = ndiag(ndiagnum) + 1  
        _END_MASTER(myThid)  
91    
92         offset = ib*(npeice-1)         offset = ib*(npeice-1)
93         Lena    = min(ib,numpts-offset)         Lena    = min(ib,numpts-offset)
# Line 110  C         and do the loop >> do k=kFirst Line 107  C         and do the loop >> do k=kFirst
107         ELSE         ELSE
108          STOP 'ABNORMAL END: S/R DIAGNOSTICS_FILL kLev > nLevs > 0'          STOP 'ABNORMAL END: S/R DIAGNOSTICS_FILL kLev > nLevs > 0'
109         ENDIF         ENDIF
110  C-      Which part of qdiag to update: kd = 3rd index,  C-      Which part of qdiag to update: kd = 3rd index,
111  C         and do the loop >> do k=kFirst,kLast ; kd = kd0 + k*ksgn <<  C         and do the loop >> do k=kFirst,kLast ; kd = kd0 + k*ksgn <<
112         IF ( kLev.EQ.-1 ) THEN         IF ( kLev.EQ.-1 ) THEN
113          ksgn = -1          ksgn = -1
# Line 127  C-      Check for consistency with Nb of Line 124  C-      Check for consistency with Nb of
124          kStore = kd0 + MAX(ksgn*kFirst,ksgn*kLast) - ipointer + 1          kStore = kd0 + MAX(ksgn*kFirst,ksgn*kLast) - ipointer + 1
125         IF ( kStore.GT.kdiag(ndiagnum) ) THEN         IF ( kStore.GT.kdiag(ndiagnum) ) THEN
126          _BEGIN_MASTER(myThid)          _BEGIN_MASTER(myThid)
127          WRITE(msgBuf,'(2A,I3,A)') 'DIAGNOSTICS_FILL: ',          WRITE(msgBuf,'(2A,I4,A)') 'DIAGNOSTICS_FILL: ',
128       .     'exceed Nb of levels(=',kdiag(ndiagnum),' ) reserved '       &     'exceed Nb of levels(=',kdiag(ndiagnum),' ) reserved '
129          CALL PRINT_ERROR( msgBuf , myThid )          CALL PRINT_ERROR( msgBuf , myThid )
130          WRITE(msgBuf,'(2A,I4,2A)') 'DIAGNOSTICS_FILL: ',          WRITE(msgBuf,'(2A,I6,2A)') 'DIAGNOSTICS_FILL: ',
131       .     'for Diagnostics #', ndiagnum, ' : ', chardiag       &     'for Diagnostics #', ndiagnum, ' : ', chardiag
132          CALL PRINT_ERROR( msgBuf , myThid )          CALL PRINT_ERROR( msgBuf , myThid )
133          WRITE(msgBuf,'(2A,2I4,I3)') 'calling DIAGNOSTICS_FILL ',          WRITE(msgBuf,'(2A,2I4,I3)') 'calling DIAGNOSTICS_FILL ',
134       .     'with kLev,nLevs=', kLev,nLevs       &     'with kLev,nLevs=', kLev,nLevs
135          CALL PRINT_ERROR( msgBuf , myThid )          CALL PRINT_ERROR( msgBuf , myThid )
136          WRITE(msgBuf,'(2A,I6,A)') 'DIAGNOSTICS_FILL: ',          WRITE(msgBuf,'(2A,I6,A)') 'DIAGNOSTICS_FILL: ',
137       .     '==> trying to store up to ', kStore, ' levels'       &     '==> trying to store up to ', kStore, ' levels'
138          CALL PRINT_ERROR( msgBuf , myThid )          CALL PRINT_ERROR( msgBuf , myThid )
139          STOP 'ABNORMAL END: S/R DIAGNOSTICS_FILL'          STOP 'ABNORMAL END: S/R DIAGNOSTICS_FILL'
140          _END_MASTER(myThid)          _END_MASTER(myThid)
# Line 150  C-      Check for consistency with Nb of Line 147  C-      Check for consistency with Nb of
147           do i= 1,Lena           do i= 1,Lena
148            jindx = 1 + int((indx(i+offset-1)-1)/sNx)            jindx = 1 + int((indx(i+offset-1)-1)/sNx)
149            newindx = indx(i+offset-1)+(jindx-1)*2*Olx            newindx = indx(i+offset-1)+(jindx-1)*2*Olx
150            if(qdiag(newindx,1,kd,bi,bj).eq.undef            if(qdiag(newindx,1,kd,bi,bj).eq.undef
151       .                                  .or.field(i,k).eq.undef)then       .                                  .or.field(i,k).eq.undef)then
152             qdiag(newindx,1,kd,bi,bj) = undef             qdiag(newindx,1,kd,bi,bj) = undef
153            else            else
# Line 168  C-      Check for consistency with Nb of Line 165  C-      Check for consistency with Nb of
165          endif          endif
166         ENDDO         ENDDO
167    
168        ELSE  C--   do the filling: ends here.
169  C     IF (myThid.EQ.1) WRITE(6,1000) chardiag           ENDIF
170        ENDIF          ENDIF
171           ENDDO
172   1000 format(' ',' Warning: Trying to write to diagnostic ',a8,        ENDDO
173       .        ' But it is not a valid (or active) name ')  
174        RETURN  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
175    C--   Global/Regional Statistics :
176          scaleFact = 1. _d 0
177    
178    C Run through list of active statistics-diagnostics to make sure
179    C we are trying to compute & fill a valid diagnostic
180    
181          DO n=1,diagSt_nbLists
182           DO m=1,diagSt_nbActv(n)
183            IF ( chardiag.EQ.diagSt_Flds(m,n) .AND. iSdiag(m,n).GT.0 ) THEN
184             iSp = iSdiag(m,n)
185             IF ( qSdiag(0,0,iSp,bi,bj).GE.0. ) THEN
186               ndId = jSdiag(m,n)
187    C-    Find list of regions to fill:
188               DO j=0,nRegions
189                region2fill(j) = diagSt_region(j,n)
190               ENDDO
191    C-    if this diagnostics appears in several lists (with same freq)
192    C     then add regions from other lists
193               DO l=1,diagSt_nbLists
194                DO k=1,diagSt_nbActv(l)
195                 IF ( iSdiag(k,l).EQ.-iSp ) THEN
196                  DO j=0,nRegions
197                   region2fill(j) = MAX(region2fill(j),diagSt_region(j,l))
198                  ENDDO
199                 ENDIF
200                ENDDO
201               ENDDO
202    
203    C-      Which part of field to add : k = 3rd index,
204    C         and do the loop >> do k=kFirst,kLast <<
205           IF (kLev.LE.0) THEN
206            kFirst = 1
207            kLast  = nLevs
208           ELSE
209            kFirst = 1
210            kLast  = 1
211           ENDIF
212    
213    C-    Fill local array with grid-space field after conversion.
214           offset = ib*(npeice-1)
215           Lena    = min(ib,numpts-offset)
216           offset = offset+1
217    
218           DO i=1,sNx*sNy
219             gridFrac(i)= 0.
220           ENDDO
221           DO i=1,Lena
222             newindx = indx(i+offset-1)
223             gridFrac(newindx)=gridFrac(newindx)+chfr(i)
224           ENDDO
225    
226           DO k = kFirst,kLast
227            DO i=1,sNx*sNy
228             gridField(i,k)= 0.
229            ENDDO
230            if( check ) then
231             undef = getcon('UNDEF')
232             do i= 1,Lena
233              newindx = indx(i+offset-1)
234              if(gridField(newindx,k).eq.undef
235         .                           .or.field(i,k).eq.undef)then
236               gridField(newindx,k)= undef
237              else
238               gridField(newindx,k)=gridField(newindx,k)
239         &                         +field(i,k)*chfr(i)/gridFrac(newindx)
240              endif
241             enddo
242            else
243             do i= 1,Lena
244              newindx = indx(i+offset-1)
245              gridField(newindx,k)=gridField(newindx,k)
246         &                        +field(i,k)*chfr(i)/gridFrac(newindx)
247             enddo
248            endif
249           ENDDO
250    
251    C-    diagnostics is valid and Active: Now do the filling
252               CALL DIAGSTATS_FILL(
253         I              gridField, gridFrac, scaleFact, 1, 1,
254         I              ndId, iSp, region2fill, kLev, nLevs,
255         I              3, bi, bj, myThid )
256             ENDIF
257            ENDIF
258           ENDDO
259          ENDDO
260    
261          RETURN
262        END        END
Legend:
Removed from v.1.5  
changed lines
  Added in v.1.8
  ViewVC Help
Powered by ViewVC 1.1.22