pkg/obcs/obcs_cost_ob_n.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_N
                0008
                0009 C !INTERFACE: ==========================================================
                0010       SUBROUTINE OBCS_COST_OB_N(
                0011      I                           startrec, endrec,
                0012      I                           myTime, myIter, myThid )
                0013
                0014 C !DESCRIPTION:
                0015 C     - Calculatesd cost function contribution (Tikhonov regulariation)
                0016 C       of northern open-boundary
                0017 C     - modified from pkg/ecco/cost_obcsn.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_OBCSN_CONTROL && defined ALLOW_COST
                0042 C !FUNCTIONS: ==========================================================
                0043       INTEGER  ILNBLNK
                0044       EXTERNAL ILNBLNK
                0045
                0046 C !LOCAL VARIABLES: ====================================================
                0047       INTEGER bi,bj
                0048       INTEGER i,k
                0049       INTEGER imin,imax
                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-OLx:sNx+OLx,Nr,nSx,nSy)
                0063       _RL maskxz   (1-OLx:sNx+OLx,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       imin = 1
                0071       imax = sNx
                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     jp1 = 0
                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_N: 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_obcsN_file )
                0103        WRITE(fnamefld,'(2a,i10.10)')
                0104      &      xx_obcsN_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_XZ( fnamefld, tmpfield, irec,
                0112      &                      doglobalread, ladinit, optimcycle,
                0113      &                      myThid, xx_obcsN_dummy )
                0114 #else
                0115        CALL READ_REC_XZ_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_XZ( 'maskobcsn', maskxz, iobcs,
                0126      &                      doglobalread, ladinit, 0,
                0127      &                      myThid, dummy )
                0128 #else
                0129        CALL READ_REC_XZ_RL( 'maskobcsn', ctrlprec, Nr,
                0130      &                      maskxz, 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 i = imin,imax
                0142 c          j = OB_Jn(I,bi,bj)
                0143 cgg        IF (maskS(i,j+jp1,k,bi,bj) .NE. 0.) THEN
                0144            tmpx = tmpfield(i,k,bi,bj)
                0145 CMM        fctile = fctile + wobcsN2(i,k,bi,bj,iobcs)
                0146            fctile = fctile + wobcsN(k,iobcs)
                0147      &                       *tmpx*tmpx*maskxz(i,k,bi,bj)
                0148 cgg        ENDIF
                0149 CMM        IF (wobcsN2(i,k,bi,bj,iobcs)*maskxz(i,k,bi,bj).NE.0.)
                0150            IF (wobcsN(k,iobcs)*maskxz(i,k,bi,bj).NE.0.)
                0151      &          num_obcsN(bi,bj) = num_obcsN(bi,bj) + 1. _d 0
                0152 cgg        PRINT*,'S fctile',fctile
                0153           ENDDO
                0154          ENDDO
                0155
                0156          objf_obcsN(bi,bj) = objf_obcsN(bi,bj) + fctile
                0157          fcthread          = fcthread + fctile
                0158         ENDDO
                0159        ENDDO
                0160
                0161        IF ( debugLevel.GE.debLevC ) THEN
                0162 c--     Print cost function for all tiles.
                0163         _GLOBAL_SUM_RL( fcthread , myThid )
                0164         WRITE(msgBuf,'(a)') ' '
                0165         CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0166      &                      SQUEEZE_RIGHT, myThid )
                0167         WRITE(msgBuf,'(a,i8.8)')
                0168      &    ' OBCS_COST_OB_N: irec = ',irec
                0169         CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0170      &                      SQUEEZE_RIGHT, myThid )
                0171         WRITE(msgBuf,'(a,a,d22.15)')
                0172      &    ' global cost function value',
                0173      &    ' (obcsN) = ',fcthread
                0174         CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0175      &                      SQUEEZE_RIGHT, myThid )
                0176         WRITE(msgBuf,'(a)') ' '
                0177         CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0178      &                      SQUEEZE_RIGHT, myThid )
                0179        ENDIF
                0180
                0181       ENDDO
                0182 c--   End of loop over records.
                0183
                0184 #endif /* ALLOW_CTRL etc */
                0185
                0186       RETURN
                0187       END