/[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.9 by jmc, Sun Jun 26 16:51:49 2005 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***********************************************************************
14    C   Wrapper routine to increment the diagnostics arrays with a field
15    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***********************************************************************  C***********************************************************************
 C  Purpose  
 C  -------  
 C   Wrapper routine to increment the diagnostics array with a field  
 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 (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 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                  (whether to fill-in all the levels (kLev<1) or just one (kLev>0))
38  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  
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 31  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     bi ......... X-direction process(or) number - used for bibjflg=1-3  C                  NOTE - bibjFlg can be NEGATIVE to indicate not to increment counter
47  C     bj ......... Y-direction process(or) 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         implicit none        _RL inpfld(*)
56  #include "EEPARAMS.h"        CHARACTER*8 chardiag
57  #include "SIZE.h"        INTEGER kLev, nLevs, bibjFlg, biArg, bjArg
58  #include "DIAGNOSTICS_SIZE.h"        INTEGER myThid
59  #include "DIAGNOSTICS.h"  CEOP
60    
61        integer myThid,levflg,nlevs,bibjflg,bi,bj  C     !LOCAL VARIABLES:
62        character *8 chardiag  C     ndId      :: diagnostic Id number (in available diagnostics list)
63        _RL arrayin(*)  C ===============
64          INTEGER m, n, j, k, l, bi, bj
65  c Local variables        INTEGER ndId, ipt, iSp
66  c ===============        INTEGER region2fill(0:nRegions)
67        integer i, j, m, n  
68        integer ndiagnum, bihere, bjhere, levhere, ipointer        IF ( bibjFlg.EQ.0 ) THEN
69        _RL array(1-OLx:sNx+OLx,1-OLy:sNy+OLy)          bi = 1
70        _RL arrayloc(sNx,sNy)          bj = 1
71        integer irun,jrun,krun,birun,bjrun        ELSE
72        integer level          bi = biArg
73            bj = bjArg
74          ENDIF
75    C--   2D/3D Diagnostics :
76  C Run through list of active diagnostics to make sure  C Run through list of active diagnostics to make sure
77  C we are trying to fill a valid diagnostic  C we are trying to fill a valid diagnostic
   
       ndiagnum = 0  
       ipointer = 0  
78        DO n=1,nlists        DO n=1,nlists
79         DO m=1,nActive(n)         DO m=1,nActive(n)
80          IF ( chardiag.EQ.flds(m,n) ) THEN          IF ( chardiag.EQ.flds(m,n) .AND. idiag(m,n).GT.0 ) THEN
81           ndiagnum = jdiag(m,n)           ipt = idiag(m,n)
82           ipointer = idiag(ndiagnum)           IF ( ndiag(ipt,bi,bj).GE.0 ) THEN
83    C diagnostic is valid & active, do the filling:
84               ndId = jdiag(m,n)
85               CALL DIAGNOSTICS_FILL_FIELD( inpfld, ndId, ipt,
86         I                kLev, nLevs, bibjFlg, biArg, bjArg, myThid )
87             ENDIF
88          ENDIF          ENDIF
89         ENDDO         ENDDO
90        ENDDO        ENDDO
91    
 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  
   
92  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
93        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  
94    
95         enddo  C Run through list of active statistics-diagnostics to make sure
96         enddo  C we are trying to compute & fill a valid diagnostic
97    
98  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|        DO n=1,diagSt_nbLists
99        elseif(bibjflg.eq.1) then         DO m=1,diagSt_nbActv(n)
100         irun = sNx+2*OLx          IF ( chardiag.EQ.diagSt_Flds(m,n) .AND. iSdiag(m,n).GT.0 ) THEN
101         jrun = sNy+2*OLy           iSp = iSdiag(m,n)
102         krun = abs(nlevs)           IF ( qSdiag(0,0,iSp,bi,bj).GE.0. ) THEN
103         birun = nSx  C-         diagnostics is valid and Active. Find list of regions to fill:
104         bjrun = nSy             DO j=0,nRegions
105                region2fill(j) = diagSt_region(j,n)
106         if(levflg.eq.0)then             ENDDO
107          do levhere = 1,krun  C-         if this diagnostics appears in several lists (with same freq)
108           level = levhere  C          then add regions from other lists
109           IF (nlevs.LT.0) level=1-nlevs-levhere             DO l=1,diagSt_nbLists
110           call diagnostics_fillit(arrayin,irun,jrun,krun,levhere,              DO k=1,diagSt_nbActv(l)
111       .                           birun,bjrun,bi,bj,array,myThid)               IF ( iSdiag(k,l).EQ.-iSp ) THEN
112           do j = 1,sNy                DO j=0,nRegions
113           do i = 1,sNx                 region2fill(j) = MAX(region2fill(j),diagSt_region(j,l))
114            qdiag(i,j,ipointer+level-1,bi,bj) =                ENDDO
115       .  qdiag(i,j,ipointer+level-1,bi,bj) +               ENDIF
116       .                       array(i,j)              ENDDO
117           enddo             ENDDO
118           enddo  C-         Now do the filling :
119          enddo             ndId = jSdiag(m,n)
120         elseif(levflg.gt.0)then             CALL DIAGSTATS_FILL( inpfld, ndId, iSp, region2fill,
121          call diagnostics_fillit(arrayin,irun,jrun,krun,levflg,       I                kLev, nLevs, bibjFlg, biArg, bjArg, myThid )
122       .                           birun,bjrun,bi,bj,array,myThid)           ENDIF
123          do j = 1,sNy          ENDIF
124          do i = 1,sNx         ENDDO
125           qdiag(i,j,ipointer+levflg-1,bi,bj) =        ENDDO
      .  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,  
      .                                       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  
126    
127        return        RETURN
128        end        END
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.9
  ViewVC Help
Powered by ViewVC 1.1.22