Back to home page

MITgcm
 
 

    

File indexing completed on 2018-03-02 18:39:03 UTC

view on githubraw file Latest commit add29e06 on 2018-01-31 20:35:05 UTC
09ceb40cd6 Jean*0001 #include "DIAG_OPTIONS.h"
                0002 
                0003 CBOP
                0004 C     !ROUTINE: DIAGNOSTICS_SETDIAG
                0005 C     !INTERFACE:
3ae5f90260 Jean*0006       SUBROUTINE DIAGNOSTICS_SETDIAG(
09ceb40cd6 Jean*0007      O                      mate,
3ae5f90260 Jean*0008      U                      ndiagmx,
                0009      I                      mId, listId, ndId, myThid )
09ceb40cd6 Jean*0010 
                0011 C     !DESCRIPTION: \bv
                0012 C     *==================================================================
                0013 C     | S/R DIAGNOSTICS_SETDIAG
3ae5f90260 Jean*0014 C     | o activate diagnostic "ndId":
09ceb40cd6 Jean*0015 C     |   set pointer locations for this diagnostic ;
                0016 C     |   look for a counter mate and set it
                0017 C     *==================================================================
                0018 C     \ev
                0019 
                0020 C     !USES:
                0021       IMPLICIT NONE
                0022 
                0023 C     == Global variables ===
                0024 #include "EEPARAMS.h"
                0025 #include "SIZE.h"
                0026 #include "DIAGNOSTICS_SIZE.h"
                0027 #include "DIAGNOSTICS.h"
                0028 
                0029 C     !INPUT/OUTPUT PARAMETERS:
                0030 C     == Routine arguments ==
3ae5f90260 Jean*0031 C     mate    :: counter-mate number in available diagnostics list
                0032 C     ndiagmx :: current space allocated in storage array
                0033 C     mId     :: current field index in list "listId"
                0034 C     listId  :: current list number that contains field "mId"
                0035 C     ndId    :: diagnostic number in available diagnostics list
                0036 C     myThid  :: Thread number for this instance of the routine.
09ceb40cd6 Jean*0037       INTEGER mate
                0038       INTEGER ndiagmx
3ae5f90260 Jean*0039       INTEGER mId, listId, ndId
09ceb40cd6 Jean*0040       INTEGER myThid
                0041 CEOP
                0042 
                0043 C     !LOCAL VARIABLES:
                0044 C     == Local variables ==
                0045       INTEGER stdUnit, errUnit
fd31448e60 Jean*0046       INTEGER nn, k, l, no_hFac
                0047       LOGICAL diagIsPP, flagD, flagP, flagM, use_hFac
09ceb40cd6 Jean*0048 
931cda44c0 Jean*0049       CHARACTER*10 gcode
b69fcb6385 Jean*0050       CHARACTER*12 tmpMsg
09ceb40cd6 Jean*0051       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0052 
                0053 C **********************************************************************
931cda44c0 Jean*0054 C ****                SET POINTERS FOR DIAGNOSTIC ndId              ****
09ceb40cd6 Jean*0055 C **********************************************************************
                0056 
                0057       stdUnit = standardMessageUnit
                0058       errUnit = errorMessageUnit
                0059 
e2b0f3f4e8 Jean*0060 C-    Case of Post-Procesed diag, not filled up but computed from other diags:
                0061       diagIsPP = gdiag(ndId)(5:5).EQ.'P'
                0062 
fd31448e60 Jean*0063 C-    Register negative "jdiag" when cumulating thickness (hFac) weighted field
                0064       no_hFac = 1
                0065       IF ( fflags(listId)(3:3).EQ.'h' ) THEN
                0066         gcode = gdiag(ndId)(1:10)
                0067         use_hFac = ( gcode(2:2).EQ.'U' .OR. gcode(2:2).EQ.'V'
                0068      &                                 .OR. gcode(2:2).EQ.'M' )
                0069         use_hFac = use_hFac .AND. gcode(9:10).EQ.'MR'
                0070      &                      .AND. gcode(3:3).EQ.'R'
                0071      &                      .AND. gcode(5:5).EQ.' '
                0072         IF ( use_hFac ) no_hFac = -1
                0073       ENDIF
                0074 
e2b0f3f4e8 Jean*0075 C---  Seach for the same diag (with same freq) to see if already set
                0076 C     do it recursively on Post-Processed diag dependance (=mate)
                0077 C     until we find either one already set or a non Post-Processed diag
                0078       flagD = .TRUE.
                0079       flagP = .TRUE.
                0080       nn = ndId
                0081       DO WHILE ( flagP )
                0082         DO l=1,listId
                0083          IF (flagD .AND. freq(l) .EQ. freq(listId)
                0084      &             .AND. phase(l).EQ.phase(listId)
                0085      &             .AND. averageFreq(l) .EQ.averageFreq(listId)
                0086      &             .AND. averagePhase(l).EQ.averagePhase(listId)
                0087      &             .AND. averageCycle(l).EQ.averageCycle(listId) ) THEN
                0088           DO k=1,MIN(nActive(l),numperList)
fd31448e60 Jean*0089            IF ( flagD .AND. no_hFac*jdiag(k,l).GT.0 ) THEN
                0090             IF ( cdiag(nn).EQ.cdiag(ABS(jdiag(k,l))) ) THEN
3ae5f90260 Jean*0091 C-    diagnostics already set ; use the same slot:
e2b0f3f4e8 Jean*0092              flagD = .FALSE.
                0093              idiag(mId,listId) = -ABS(idiag(k,l))
                0094              mdiag(mId,listId) = mdiag(k,l)
                0095             ENDIF
                0096            ENDIF
                0097           ENDDO
3ae5f90260 Jean*0098          ENDIF
                0099         ENDDO
e2b0f3f4e8 Jean*0100         flagP = flagD .AND. gdiag(nn)(5:5).EQ.'P'
                0101         IF ( flagP ) nn = hdiag(nn)
3ae5f90260 Jean*0102       ENDDO
fd31448e60 Jean*0103       jdiag(mId,listId) = no_hFac*ndId
3ae5f90260 Jean*0104 
e2b0f3f4e8 Jean*0105 C---  Set pointer if not already set, otherwise just print a message
3ae5f90260 Jean*0106 
e2b0f3f4e8 Jean*0107       IF ( diagIsPP ) THEN
                0108         WRITE(msgBuf,'(2(A,I6,1X,A))')
                0109      &    'SETDIAG: Diag #', ndId, cdiag(ndId),
                0110      &    ' processed from Diag #',nn,cdiag(nn)
                0111         CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
                0112       ENDIF
                0113       gcode   = gdiag(nn)(1:10)
                0114       IF ( flagD ) THEN
                0115         IF ( diagIsPP ) THEN
6d9af5b863 Jean*0116 C-      Add this diag with negative idiag pointer (since those 2 diags
                0117 C        share the same pointer and "nn" will get the positive pointer).
                0118           idiag(mId,listId) = -(ndiagmx+1)
e2b0f3f4e8 Jean*0119 C-      Also add "nn" to the Active list
                0120           k = nActive(listId) + 1
                0121           IF ( k.LE.numperList ) THEN
                0122             jdiag(k,listId) = nn
                0123             idiag(k,listId) = ndiagmx + 1
                0124             flds (k,listId) = cdiag(nn)
                0125           ENDIF
                0126           nActive(listId) = k
6d9af5b863 Jean*0127         ELSE
                0128           idiag(mId,listId) = ndiagmx + 1
e2b0f3f4e8 Jean*0129         ENDIF
                0130         ndiagmx = ndiagmx + kdiag(nn)*averageCycle(listId)
931cda44c0 Jean*0131         IF ( ndiagmx.GT.numDiags ) THEN
                0132          WRITE(msgBuf,'(A,I6,1X,A)')
e2b0f3f4e8 Jean*0133      &    'SETDIAG: Not enough space for Diagnostic #',nn,cdiag(nn)
09ceb40cd6 Jean*0134          CALL PRINT_MESSAGE(msgBuf, errUnit, SQUEEZE_RIGHT, myThid)
                0135         ELSE
931cda44c0 Jean*0136          WRITE(msgBuf,'(A,2(I3,A),I6,1X,A)') 'SETDIAG: Allocate',
e2b0f3f4e8 Jean*0137      &                   kdiag(nn), ' x', averageCycle(listId),
                0138      &                ' Levels for Diagnostic #', nn, cdiag(nn)
09ceb40cd6 Jean*0139          CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
                0140         ENDIF
                0141       ELSE
b69fcb6385 Jean*0142         tmpMsg = ' Diagnostic '
                0143         WRITE(msgBuf,'(3A,I6,1X,2A)') '- NOTE - SETDIAG: ',tmpMsg,
                0144      &           ' #', nn, cdiag(nn), ' is already set'
324746cc27 Jean*0145         CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
09ceb40cd6 Jean*0146       ENDIF
                0147 
e2b0f3f4e8 Jean*0148 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
324746cc27 Jean*0149 
e2b0f3f4e8 Jean*0150 C---  Check for Counter Diagnostic
09ceb40cd6 Jean*0151       mate = 0
e2b0f3f4e8 Jean*0152 
                0153 C-    if Post-Processed diag, activate 2nd components of vector field
b69fcb6385 Jean*0154       tmpMsg = ' Vector-mate'
e2b0f3f4e8 Jean*0155       IF ( diagIsPP .AND. gcode(5:5).NE.'P' .AND.
                0156      &    (gcode(1:1).EQ.'U' .OR. gcode(1:1).EQ.'V') ) mate = hdiag(nn)
                0157 C-    activate mate if this is a Counter Diagnostic
931cda44c0 Jean*0158       IF ( gcode(5:5).EQ.'C') THEN
e2b0f3f4e8 Jean*0159         mate = hdiag(nn)
b69fcb6385 Jean*0160         tmpMsg = 'Counter-mate'
e2b0f3f4e8 Jean*0161       ENDIF
09ceb40cd6 Jean*0162 
e2b0f3f4e8 Jean*0163       IF ( mate.GT.0 ) THEN
3ae5f90260 Jean*0164 C--     Seach for the same diag (with same freq) to see if already set
e2b0f3f4e8 Jean*0165         flagM = .TRUE.
3ae5f90260 Jean*0166         DO l=1,listId
e2b0f3f4e8 Jean*0167          IF (flagM .AND. freq(l) .EQ.freq(listId)
                0168      &             .AND. phase(l).EQ.phase(listId)
                0169      &             .AND. averageFreq(l) .EQ.averageFreq(listId)
                0170      &             .AND. averagePhase(l).EQ.averagePhase(listId)
                0171      &             .AND. averageCycle(l).EQ.averageCycle(listId) ) THEN
                0172           DO k=1,MIN(nActive(l),numperList)
                0173            IF (flagM .AND. jdiag(k,l).GT.0) THEN
3ae5f90260 Jean*0174             IF (cdiag(mate).EQ.cdiag(jdiag(k,l)) ) THEN
                0175 C-    diagnostics already set ; use the same slot:
e2b0f3f4e8 Jean*0176              flagM = .FALSE.
3ae5f90260 Jean*0177              mdiag(mId,listId) = ABS(idiag(k,l))
                0178             ENDIF
                0179            ENDIF
                0180           ENDDO
                0181          ENDIF
                0182         ENDDO
                0183 
e2b0f3f4e8 Jean*0184 C---  Set pointer if not already set, otherwise just print a message
                0185         IF ( flagM ) THEN
666b944083 Jean*0186           mdiag(mId,listId) = ndiagmx + 1
e2b0f3f4e8 Jean*0187           k = nActive(listId) + 1
                0188           IF ( k.LE.numperList ) THEN
                0189 C-      Also add mate to the Active list
                0190             jdiag(k,listId) = mate
                0191             idiag(k,listId) = ndiagmx + 1
                0192             flds (k,listId) = cdiag(mate)
                0193           ENDIF
                0194           nActive(listId) = k
666b944083 Jean*0195           ndiagmx = ndiagmx + kdiag(mate)*averageCycle(listId)
931cda44c0 Jean*0196           IF ( ndiagmx.GT.numDiags ) THEN
e2b0f3f4e8 Jean*0197            WRITE(msgBuf,'(3A,I6,1X,A)')
                0198      &      'SETDIAG: Not enough space for ',tmpMsg,' #',
3ae5f90260 Jean*0199      &      mate, cdiag(mate)
09ceb40cd6 Jean*0200            CALL PRINT_MESSAGE(msgBuf, errUnit, SQUEEZE_RIGHT, myThid)
                0201           ELSE
931cda44c0 Jean*0202            WRITE(msgBuf,'(A,2(I3,A),I6,1X,A)') 'SETDIAG: Allocate',
666b944083 Jean*0203      &                     kdiag(mate), ' x', averageCycle(listId),
e2b0f3f4e8 Jean*0204      &                  ' Levels for Mate Diag. #', mate, cdiag(mate)
09ceb40cd6 Jean*0205            CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
                0206           ENDIF
                0207         ELSE
e2b0f3f4e8 Jean*0208           WRITE(msgBuf,'(3A,I6,1X,2A)') '- NOTE - SETDIAG: ',tmpMsg,
                0209      &    ' #', mate, cdiag(mate), ' is already set'
09ceb40cd6 Jean*0210           CALL PRINT_MESSAGE(msgBuf, stdUnit, SQUEEZE_RIGHT, myThid)
                0211         ENDIF
                0212       ENDIF
                0213 
                0214 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0215       RETURN
                0216       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
Valid CSS 2.1! Valid HTML 4.01!