/[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.13 by jmc, Mon Jul 31 16:26:32 2006 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(
10         I               inpFld, chardiag,
11         I               kLev, nLevs, bibjFlg, biArg, bjArg, myThid )
12    
13    C     !DESCRIPTION:
14    C***********************************************************************
15    C   Wrapper routine to increment the diagnostics arrays with a field
16    C***********************************************************************
17    C     !USES:
18          IMPLICIT NONE
19    
20    C     == Global variables ===
21    #include "EEPARAMS.h"
22    #include "SIZE.h"
23    #include "DIAGNOSTICS_SIZE.h"
24    #include "DIAGNOSTICS.h"
25    
26    C     !INPUT PARAMETERS:
27  C***********************************************************************  C***********************************************************************
 C  Purpose  
 C  -------  
 C   Wrapper routine to increment the diagnostics array with a field  
 C  
28  C  Arguments Description  C  Arguments Description
29  C  ----------------------  C  ----------------------
30  C     arrayin .... Field to increment diagnostics array  C     inpFld    :: Field to increment diagnostics array
31  C     chardiag ... Character expression for diag to fill  C     chardiag  :: Character expression for diag to fill
32  C     levflg ..... Integer flag for vertical levels:  C     kLev      :: Integer flag for vertical levels:
33  C                  0 indicates multiple levels incremented in qdiag  C                  > 0 (any integer): WHICH single level to increment in qdiag.
34  C                  non-0 (any integer) - WHICH single level to increment.  C                  0,-1 to increment "nLevs" levels in qdiag,
35  C                  negative integer - the input data array is single-leveled  C                  0 : fill-in in the same order as the input array
36  C                  positive integer - the input data array is multi-leveled  C                  -1: fill-in in reverse order.
37  C     nlevs ...... indicates Number of levels to be filled (1 if levflg <> 0)  C     nLevs     :: indicates Number of levels of the input field array
38  C                  positive: fill in "nlevs" levels in the same order as  C                  (whether to fill-in all the levels (kLev<1) or just one (kLev>0))
39  C                            the input array  C     bibjFlg   :: Integer flag to indicate instructions for bi bj loop
 C                  negative: fill in -nlevs levels in reverse order.  
 C     bibjflg .... Integer flag to indicate instructions for bi bj loop  
40  C                  0 indicates that the bi-bj loop must be done here  C                  0 indicates that the bi-bj loop must be done here
41  C                  1 indicates that the bi-bj loop is done OUTSIDE  C                  1 indicates that the bi-bj loop is done OUTSIDE
42  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 44  C                     AND that we have b
44  C                  3 indicates that the bi-bj loop is done OUTSIDE  C                  3 indicates that the bi-bj loop is done OUTSIDE
45  C                     AND that we have been sent a local array  C                     AND that we have been sent a local array
46  C                     AND that the array has no overlap region (interior only)  C                     AND that the array has no overlap region (interior only)
47  C     bi ......... X-direction process(or) number - used for bibjflg=1-3  C                  NOTE - bibjFlg can be NEGATIVE to indicate not to increment counter
48  C     bj ......... Y-direction process(or) number - used for bibjflg=1-3  C     biArg     :: X-direction tile number - used for bibjFlg=1-3
49  C     myThid     ::  my thread Id number  C     bjArg     :: Y-direction tile number - used for bibjFlg=1-3
50    C     myThid    ::  my thread Id number
51  C***********************************************************************  C***********************************************************************
52  C                  NOTE: User beware! If a local (1 tile only) array  C                  NOTE: User beware! If a local (1 tile only) array
53  C                        is sent here, bibjflg MUST NOT be set to 0  C                        is sent here, bibjFlg MUST NOT be set to 0
54  C                        or there will be out of bounds problems!  C                        or there will be out of bounds problems!
55  C***********************************************************************  C***********************************************************************
56         implicit none        _RL     inpFld(*)
57  #include "EEPARAMS.h"        CHARACTER*8 chardiag
58  #include "SIZE.h"        INTEGER kLev, nLevs, bibjFlg, biArg, bjArg
59  #include "DIAGNOSTICS_SIZE.h"        INTEGER myThid
60  #include "DIAGNOSTICS.h"  CEOP
61    
62        integer myThid,levflg,nlevs,bibjflg,bi,bj  C     !LOCAL VARIABLES:
63        character *8 chardiag  C     ndId      :: diagnostic Id number (in available diagnostics list)
64        _RL arrayin(*)  C ===============
65          INTEGER m, n, j, k, l, bi, bj
66  c Local variables        INTEGER ndId, ipt, iSp
67  c ===============        INTEGER region2fill(0:nRegions)
68        integer i, j, m, n        _RL     scaleFact
69        integer ndiagnum, bihere, bjhere, levhere, ipointer  
70        _RL array(1-OLx:sNx+OLx,1-OLy:sNy+OLy)        scaleFact = 1. _d 0
71        _RL arrayloc(sNx,sNy)        IF ( bibjFlg.EQ.0 ) THEN
72        integer irun,jrun,krun,birun,bjrun          bi = myBxLo(myThid)
73        integer level          bj = myByLo(myThid)
74          ELSE
75            bi = biArg
76            bj = bjArg
77          ENDIF
78    C--   2D/3D Diagnostics :
79  C Run through list of active diagnostics to make sure  C Run through list of active diagnostics to make sure
80  C we are trying to fill a valid diagnostic  C we are trying to fill a valid diagnostic
   
       ndiagnum = 0  
       ipointer = 0  
81        DO n=1,nlists        DO n=1,nlists
82         DO m=1,nActive(n)         DO m=1,nActive(n)
83          IF ( chardiag.EQ.flds(m,n) ) THEN          IF ( chardiag.EQ.flds(m,n) .AND. idiag(m,n).GT.0 ) THEN
84           ndiagnum = jdiag(m,n)           ipt = idiag(m,n)
85           ipointer = idiag(ndiagnum)           IF ( ndiag(ipt,bi,bj).GE.0 ) THEN
86               ndId = jdiag(m,n)
87               ipt = ipt + pdiag(n,bi,bj)*kdiag(ndId)
88    C-    diagnostic is valid & active, do the filling:
89               CALL DIAGNOSTICS_FILL_FIELD(
90         I              inpFld, inpFld, scaleFact, 1, 0,
91         I              ndId, ipt, kLev, nLevs,
92         I              bibjFlg, biArg, bjArg, myThid )
93             ENDIF
94          ENDIF          ENDIF
95         ENDDO         ENDDO
96        ENDDO        ENDDO
97    
 C If-sequence to see if we are a valid and an active diagnostic  
   
       IF ( ndiagnum.ne.0 .and. ipointer.ne.0 ) THEN  
   
 C Increment the counter for the diagnostic (if we are at bi=bj=1)  
       _BEGIN_MASTER(myThid)  
       if ((bi.eq.1).and.(bj.eq.1).and.(abs(levflg).le.1) )  
      .                     ndiag(ndiagnum) = ndiag(ndiagnum) + 1  
       _END_MASTER(myThid)  
   
 C   Check to see if we need to do a bi-bj loop here  
   
98  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
99        if(bibjflg.eq.0) then  C--   Global/Regional Statistics :
        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 Run through list of active statistics-diagnostics to make sure
102         enddo  C we are trying to compute & fill a valid diagnostic
103    
104  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|        DO n=1,diagSt_nbLists
105        elseif(bibjflg.eq.1) then         DO m=1,diagSt_nbActv(n)
106         irun = sNx+2*OLx          IF ( chardiag.EQ.diagSt_Flds(m,n) .AND. iSdiag(m,n).GT.0 ) THEN
107         jrun = sNy+2*OLy           iSp = iSdiag(m,n)
108         krun = abs(nlevs)           IF ( qSdiag(0,0,iSp,bi,bj).GE.0. ) THEN
109         birun = nSx             ndId = jSdiag(m,n)
110         bjrun = nSy  C-    Find list of regions to fill:
111               DO j=0,nRegions
112         if(levflg.eq.0)then              region2fill(j) = diagSt_region(j,n)
113          do levhere = 1,krun             ENDDO
114           level = levhere  C-    if this diagnostics appears in several lists (with same freq)
115           IF (nlevs.LT.0) level=1-nlevs-levhere  C     then add regions from other lists
116           call diagnostics_fillit(arrayin,irun,jrun,krun,levhere,             DO l=1,diagSt_nbLists
117       .                           birun,bjrun,bi,bj,array,myThid)              DO k=1,diagSt_nbActv(l)
118           do j = 1,sNy               IF ( iSdiag(k,l).EQ.-iSp ) THEN
119           do i = 1,sNx                DO j=0,nRegions
120            qdiag(i,j,ipointer+level-1,bi,bj) =                 region2fill(j) = MAX(region2fill(j),diagSt_region(j,l))
121       .  qdiag(i,j,ipointer+level-1,bi,bj) +                ENDDO
122       .                       array(i,j)               ENDIF
123           enddo              ENDDO
124           enddo             ENDDO
125          enddo  C-    diagnostics is valid and Active: Now do the filling
126         elseif(levflg.gt.0)then             CALL DIAGSTATS_FILL(
127          call diagnostics_fillit(arrayin,irun,jrun,krun,levflg,       I              inpFld, inpFld, scaleFact, 1, 0,
128       .                           birun,bjrun,bi,bj,array,myThid)       I              ndId, iSp, region2fill, kLev, nLevs,
129          do j = 1,sNy       I              bibjFlg, biArg, bjArg, myThid )
130          do i = 1,sNx           ENDIF
131           qdiag(i,j,ipointer+levflg-1,bi,bj) =          ENDIF
132       .  qdiag(i,j,ipointer+levflg-1,bi,bj) + array(i,j)         ENDDO
133          enddo        ENDDO
         enddo  
        else  
         level = -1 * levflg  
         call diagnostics_fillit(arrayin,irun,jrun,1,1,birun,bjrun,  
      .                                       bi,bj,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  
   
 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  
       elseif(bibjflg.eq.3) then  
        irun = sNx  
        jrun = sNy  
        krun = abs(nlevs)  
        birun = 1  
        bjrun = 1  
   
        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,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  
         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  
   
 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  
       elseif(bibjflg.eq.2) then  
        irun = sNx+2*OLx  
        jrun = sNy+2*OLy  
        krun = abs(nlevs)  
        birun = 1  
        bjrun = 1  
   
        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,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  
         enddo  
        elseif(levflg.gt.0)then  
         call diagnostics_fillit(arrayin,irun,jrun,krun,levflg,  
      .                              birun,bjrun,1,1,array,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) + array(i,j)  
         enddo  
         enddo  
        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  
   
 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  
       endif  
   
       ELSE  
   
 C     if (myThid.eq.1) write(6,1000) chardiag  
   
       ENDIF  
   
  1000 format(' ',' Warning: Trying to write to diagnostic ',a8,  
      .        ' But it is not a valid (or active) name ')  
       return  
       end  
   
 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  
   
       subroutine diagnostics_fillit(  
      I                  arrayin,irun,jrun,krun,klevf,birun,bjrun,bi,bj,  
      O                  arrayout,  
      I                  myThid)  
   
       implicit none  
 #include "EEPARAMS.h"  
   
       integer irun, jrun, krun, klevf, birun, bjrun, bi, bj  
       _RL arrayin(irun,jrun,krun,birun,bjrun)  
       _RL arrayout(irun,jrun)  
       integer myThid  
   
       integer i, j  
   
       do j = 1,jrun  
        do i = 1,irun  
         arrayout(i,j) = arrayin(i,j,klevf,bi,bj)  
        enddo  
       enddo  
134    
135        return        RETURN
136        end        END
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.13
  ViewVC Help
Powered by ViewVC 1.1.22