|
||||
File indexing completed on 2018-03-02 18:38:57 UTC
view on githubraw file Latest commit add29e06 on 2018-01-31 20:35:05 UTCbb32d08f4a Jean*0001 #include "DIAG_OPTIONS.h" 0002 0003 CBOP 0004 C !ROUTINE: DIAGNOSTICS_FILL_RS 0005 C !INTERFACE: 0006 SUBROUTINE DIAGNOSTICS_FILL_RS( 0007 I inpFld, chardiag, 0008 I kLev, nLevs, bibjFlg, biArg, bjArg, myThid ) 0009 0010 C !DESCRIPTION: 0011 C*********************************************************************** 0012 C Wrapper routine to increment the diagnostics arrays with a RS field 0013 C*********************************************************************** 0014 C !USES: 0015 IMPLICIT NONE 0016 0017 C == Global variables === 0018 #include "EEPARAMS.h" 0019 #include "SIZE.h" 0020 #include "DIAGNOSTICS_SIZE.h" 0021 #include "DIAGNOSTICS.h" 0022 0023 C !INPUT PARAMETERS: 0024 C*********************************************************************** 0025 C Arguments Description 0026 C ---------------------- 0027 C inpFld :: Field to increment diagnostics array 0028 C chardiag :: Character expression for diag to fill 0029 C kLev :: Integer flag for vertical levels: 0030 C > 0 (any integer): WHICH single level to increment in qdiag. 0031 C 0,-1 to increment "nLevs" levels in qdiag, 0032 C 0 : fill-in in the same order as the input array 0033 C -1: fill-in in reverse order. 0034 C nLevs :: indicates Number of levels of the input field array 0035 C (whether to fill-in all the levels (kLev<1) or just one (kLev>0)) 0036 C bibjFlg :: Integer flag to indicate instructions for bi bj loop 0037 C 0 indicates that the bi-bj loop must be done here 0038 C 1 indicates that the bi-bj loop is done OUTSIDE 0039 C 2 indicates that the bi-bj loop is done OUTSIDE 0040 C AND that we have been sent a local array (with overlap regions) 35876c174e Dimi*0041 C (local array here means that it has no bi-bj dimensions) bb32d08f4a Jean*0042 C 3 indicates that the bi-bj loop is done OUTSIDE 0043 C AND that we have been sent a local array 0044 C AND that the array has no overlap region (interior only) 0045 C NOTE - bibjFlg can be NEGATIVE to indicate not to increment counter 0046 C biArg :: X-direction tile number - used for bibjFlg=1-3 0047 C bjArg :: Y-direction tile number - used for bibjFlg=1-3 0048 C myThid :: my thread Id number 0049 C*********************************************************************** 0050 C NOTE: User beware! If a local (1 tile only) array 0051 C is sent here, bibjFlg MUST NOT be set to 0 0052 C or there will be out of bounds problems! 0053 C*********************************************************************** 0054 _RS inpFld(*) 0055 CHARACTER*8 chardiag 0056 INTEGER kLev, nLevs, bibjFlg, biArg, bjArg 0057 INTEGER myThid 0058 CEOP 0059 0060 C !LOCAL VARIABLES: 0061 C ndId :: diagnostic Id number (in available diagnostics list) 0062 INTEGER m, n, j, k, l, bi, bj 0063 INTEGER ndId, ipt, iSp 0064 INTEGER region2fill(0:nRegions) e24eb5a158 Jean*0065 INTEGER arrType, wFac bb32d08f4a Jean*0066 _RL scaleFact 0067 _RL dummyRL(1) 0068 _RS dummyRS(1) 0069 C =============== 0070 102b7abbed Jean*0071 C-- Check if this S/R is called from the right place ; 0072 C needs to be after DIAGNOSTICS_SWITCH_ONOFF and before DIAGNOSTICS_WRITE 0073 IF ( diag_pkgStatus.NE.ready2fillDiags ) THEN 0074 CALL DIAGNOSTICS_STATUS_ERROR( 'DIAGNOSTICS_FILL_RS', 0075 & ' ', chardiag, ready2fillDiags, myThid ) 0076 ENDIF 0077 bb32d08f4a Jean*0078 arrType = 2 0079 scaleFact = 1. _d 0 0080 IF ( bibjFlg.EQ.0 ) THEN 0081 bi = myBxLo(myThid) 0082 bj = myByLo(myThid) 0083 ELSE 0084 bi = biArg 0085 bj = bjArg 0086 ENDIF 0087 C-- 2D/3D Diagnostics : 0088 C Run through list of active diagnostics to make sure 0089 C we are trying to fill a valid diagnostic 0090 DO n=1,nlists 0091 DO m=1,nActive(n) 0092 IF ( chardiag.EQ.flds(m,n) .AND. idiag(m,n).GT.0 ) THEN 0093 ipt = idiag(m,n) 0094 IF ( ndiag(ipt,bi,bj).GE.0 ) THEN e24eb5a158 Jean*0095 ndId = ABS(jdiag(m,n)) 0096 wFac = MIN( jdiag(m,n), 0 ) bb32d08f4a Jean*0097 ipt = ipt + pdiag(n,bi,bj)*kdiag(ndId) 0098 C- diagnostic is valid & active, do the filling: 0099 CALL DIAGNOSTICS_FILL_FIELD( 0100 I dummyRL, dummyRL, inpFld, dummyRS, e24eb5a158 Jean*0101 I scaleFact, 1, arrType, wFac, bb32d08f4a Jean*0102 I ndId, ipt, kLev, nLevs, 0103 I bibjFlg, biArg, bjArg, myThid ) 0104 ENDIF 0105 ENDIF 0106 ENDDO 0107 ENDDO 0108 0109 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| 0110 C-- Global/Regional Statistics : 0111 0112 C Run through list of active statistics-diagnostics to make sure 0113 C we are trying to compute & fill a valid diagnostic 0114 0115 DO n=1,diagSt_nbLists 0116 DO m=1,diagSt_nbActv(n) 0117 IF ( chardiag.EQ.diagSt_Flds(m,n) .AND. iSdiag(m,n).GT.0 ) THEN 0118 iSp = iSdiag(m,n) 0119 IF ( qSdiag(0,0,iSp,bi,bj).GE.0. ) THEN 0120 ndId = jSdiag(m,n) 0121 C- Find list of regions to fill: 0122 DO j=0,nRegions 0123 region2fill(j) = diagSt_region(j,n) 0124 ENDDO 0125 C- if this diagnostics appears in several lists (with same freq) 0126 C then add regions from other lists 0127 DO l=1,diagSt_nbLists 0128 DO k=1,diagSt_nbActv(l) 0129 IF ( iSdiag(k,l).EQ.-iSp ) THEN 0130 DO j=0,nRegions 0131 region2fill(j) = MAX(region2fill(j),diagSt_region(j,l)) 0132 ENDDO 0133 ENDIF 0134 ENDDO 0135 ENDDO 0136 C- diagnostics is valid and Active: Now do the filling 0137 CALL DIAGSTATS_FILL( 0138 #ifdef REAL4_IS_SLOW 0139 I inpFld, dummyRL, 0140 #else 0141 I dummyRL, dummyRL, 0142 I inpFld, dummyRS, 0143 #endif 0144 I scaleFact, 1, arrType, 0, 0145 I ndId, iSp, region2fill, kLev, nLevs, 0146 I bibjFlg, biArg, bjArg, myThid ) 0147 ENDIF 0148 ENDIF 0149 ENDDO 0150 ENDDO 0151 0152 RETURN 0153 END
[ Source navigation ] | [ Diff markup ] | [ Identifier search ] | [ general search ] |
This page was automatically generated from https://github.com/MITgcm/MITgcm by the 2.2.1-MITgcm-0.1 LXR engine. The LXR team |