pkg/obcs/obcs_cost_ob_w.F

69361556c2 Mart*0001 #include "OBCS_OPTIONS.h"
                0002 #ifdef ALLOW_CTRL
                0003 # include "CTRL_OPTIONS.h"
                0004 #endif
                0005
                0006 CBOP
                0007 C !ROUTINE: OBCS_COST_OB_W
                0008
                0009 C !INTERFACE: ==========================================================
                0010       subroutine OBCS_COST_OB_W(
                0011      I                           startrec, endrec,
                0012      I                           myTime, myIter, myThid )
                0013
                0014 C !DESCRIPTION:
                0015 C     - Calculatesd cost function contribution (Tikhonov regulariation)
                0016 C       of western open-boundary
                0017 C     - modified from pkg/ecco/cost_obcsw.F
                0018
                0019 C !USES: ===============================================================
                0020       IMPLICIT NONE
                0021 C     == Global variables ==
                0022 #include "EEPARAMS.h"
                0023 #include "SIZE.h"
                0024 #include "PARAMS.h"
                0025 #include "GRID.h"
                0026 #ifdef ALLOW_CTRL
                0027 # ifndef ALLOW_AUTODIFF
                0028 #  include "CTRL_SIZE.h"
                0029 #  include "CTRL.h"
                0030 # endif
                0031 # include "OPTIMCYCLE.h"
                0032 # include "CTRL_OBCS.h"
                0033 #endif
                0034
                0035 C !INPUT PARAMETERS: ===================================================
                0036       INTEGER startrec, endrec
                0037       _RL     myTime
                0038       INTEGER myIter
                0039       INTEGER myThid
                0040
                0041 #if defined ALLOW_CTRL && defined ALLOW_OBCSW_CONTROL && defined ALLOW_COST
                0042 C !FUNCTIONS: ==========================================================
                0043       INTEGER  ILNBLNK
                0044       EXTERNAL ILNBLNK
                0045
                0046 C !LOCAL VARIABLES: ====================================================
                0047       INTEGER bi,bj
                0048       INTEGER j,k
                0049       INTEGER jmin,jmax
                0050       INTEGER irec
                0051       INTEGER iobcs
                0052       INTEGER nrec
                0053       INTEGER ilfld
                0054       INTEGER igg
                0055       _RL fctile
                0056       _RL fcthread
                0057 #ifdef ALLOW_AUTODIFF
                0058       _RL dummy
                0059 #endif
                0060       _RL gg
                0061       _RL tmpx
                0062       _RL tmpfield (1-OLy:sNy+OLy,Nr,nSx,nSy)
                0063       _RL maskyz   (1-OLy:sNy+OLy,Nr,nSx,nSy)
                0064       CHARACTER*(MAX_LEN_FNAM) fnamefld
                0065       LOGICAL doglobalread
                0066       LOGICAL ladinit
                0067       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0068 CEOP
                0069
                0070       jmin = 1
                0071       jmax = sNy
                0072
                0073 c--   Read tiled data.
                0074       doglobalread = .false.
                0075       ladinit      = .false.
                0076
                0077 c     Number of records to be used.
                0078       nrec = endrec-startrec+1
                0079
                0080 c     ip1 = 1
                0081       fcthread = 0. _d 0
                0082
                0083       IF ( debugLevel.GE.debLevC ) THEN
                0084        _BEGIN_MASTER( myThid )
                0085        WRITE(msgBuf,'(a)') ' '
                0086        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0087      &                     SQUEEZE_RIGHT, myThid )
                0088        WRITE(msgBuf,'(a)') ' '
                0089        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0090      &                     SQUEEZE_RIGHT, myThid )
                0091        WRITE(msgBuf,'(a,i9.8)')
                0092      &      ' OBCS_COST_OB_W: number of records to process: ',nrec
                0093        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0094      &                     SQUEEZE_RIGHT, myThid )
                0095        WRITE(msgBuf,'(a)') ' '
                0096        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0097      &                     SQUEEZE_RIGHT, myThid )
                0098        _END_MASTER( myThid )
                0099       ENDIF
                0100
                0101       IF (optimcycle .GE. 0) THEN
                0102        ilfld=ILNBLNK( xx_obcsW_file )
                0103        WRITE(fnamefld,'(2a,i10.10)')
                0104      &      xx_obcsW_file(1:ilfld), '.', optimcycle
                0105       ENDIF
                0106
                0107 c--   Loop over records.
                0108       DO irec = 1,nrec
                0109
                0110 #ifdef ALLOW_AUTODIFF
                0111        CALL ACTIVE_READ_YZ( fnamefld, tmpfield, irec,
                0112      &                      doglobalread, ladinit, optimcycle,
                0113      &                      myThid, xx_obcsW_dummy )
                0114 #else
                0115        CALL READ_REC_YZ_RL( fnamefld, ctrlprec, Nr,
                0116      &                      tmpfield, irec, 1, myThid )
                0117 #endif
                0118
                0119 cgg    Need to solve for iobcs would have been.
                0120        gg    = (irec-1)/nobcs
                0121        igg   = int(gg)
                0122        iobcs = irec - igg*nobcs
                0123
                0124 #ifdef ALLOW_AUTODIFF
                0125        CALL ACTIVE_READ_YZ( 'maskobcsw', maskyz, iobcs,
                0126      &                      doglobalread, ladinit, 0,
                0127      &                      myThid, dummy )
                0128 #else
                0129        CALL READ_REC_YZ_RL( 'maskobcsw', ctrlprec, Nr,
                0130      &                      maskyz, iobcs, 1, myThid )
                0131 #endif
                0132
                0133 c--   Loop over this thread s tiles.
                0134        DO bj = myByLo(myThid), myByHi(myThid)
                0135         DO bi = myBxLo(myThid), myBxHi(myThid)
                0136
                0137 c--   Determine the weights to be used.
                0138          fctile = 0. _d 0
                0139
                0140          DO k = 1, Nr
                0141           DO j = jmin,jmax
                0142 c          i = OB_Iw(j,bi,bj)
                0143 cgg        IF (maskW(i+ip1,j,k,bi,bj) .NE. 0.) THEN
                0144            tmpx = tmpfield(j,k,bi,bj)
                0145 CMM        fctile = fctile + wobcsW2(j,k,bi,bj,iobcs)
                0146            fctile = fctile + wobcsW(k,iobcs)
                0147      &          *tmpx*tmpx*maskyz(j,k,bi,bj)
                0148 cgg        ENDIF
                0149 CMM        IF (wobcsW2(j,k,bi,bj,iobcs)*maskyz(j,k,bi,bj).NE.0.)
                0150            IF (wobcsW(k,iobcs)*maskyz(j,k,bi,bj).NE.0.)
                0151      &          num_obcsW(bi,bj) = num_obcsW(bi,bj) + 1. _d 0
                0152           ENDDO
                0153          ENDDO
                0154
                0155          objf_obcsW(bi,bj) = objf_obcsW(bi,bj) + fctile
                0156          fcthread          = fcthread + fctile
                0157         ENDDO
                0158        ENDDO
                0159
                0160        IF ( debugLevel.GE.debLevC ) THEN
                0161 c--     Print cost function for all tiles.
                0162         _GLOBAL_SUM_RL( fcthread , myThid )
                0163         WRITE(msgBuf,'(a)') ' '
                0164         CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0165      &                      SQUEEZE_RIGHT, myThid )
                0166         WRITE(msgBuf,'(a,i8.8)')
                0167      &    ' OBCS_COST_OB_W: irec = ',irec
                0168         CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0169      &                      SQUEEZE_RIGHT, myThid )
                0170         WRITE(msgBuf,'(a,a,d22.15)')
                0171      &    ' global cost function value',
                0172      &    ' (obcsW) = ',fcthread
                0173         CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0174      &                      SQUEEZE_RIGHT, myThid )
                0175         WRITE(msgBuf,'(a)') ' '
                0176         CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0177      &                      SQUEEZE_RIGHT, myThid )
                0178        ENDIF
                0179
                0180       ENDDO
                0181 c--   End of loop over records.
                0182
                0183 #endif /* ALLOW_CTRL etc */
                0184
                0185       RETURN
                0186       END