pkg/cost/cost_final.F

5ed655852f Jean*0001 #include "COST_OPTIONS.h"
eaa2114d11 Jean*0002 #ifdef ALLOW_CTRL
                0003 # include "CTRL_OPTIONS.h"
                0004 #endif
2dcaa8b9a5 Patr*0005
69361556c2 Mart*0006 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0007 CBOP
                0008 C !ROUTINE: COST_FINAL
                0009
                0010 C !INTERFACE:
7883e4f1a1 Jean*0011       SUBROUTINE COST_FINAL( myThid )
2dcaa8b9a5 Patr*0012
69361556c2 Mart*0013 C     !DESCRIPTION:
                0014 C     Sum of all cost function contributions.
2dcaa8b9a5 Patr*0015
69361556c2 Mart*0016 C     !USES:
7883e4f1a1 Jean*0017       IMPLICIT NONE
69361556c2 Mart*0018 C     == Global variables ===
2dcaa8b9a5 Patr*0019 #include "EEPARAMS.h"
                0020 #include "SIZE.h"
c28cf14cd7 Patr*0021 #include "PARAMS.h"
2dcaa8b9a5 Patr*0022
                0023 #include "cost.h"
9829fd7e0c Patr*0024 #ifdef ALLOW_CTRL
69361556c2 Mart*0025 # include "OPTIMCYCLE.h"
9829fd7e0c Patr*0026 #endif
ade85a36e7 Patr*0027 #ifdef ALLOW_DIC
                0028 # include "DIC_COST.h"
                0029 #endif
64c318b5ee Patr*0030 #ifdef ALLOW_COST_SHELFICE
                0031 # include "SHELFICE_COST.h"
                0032 #endif
8f14b8ea71 Gael*0033 #ifdef ALLOW_PROFILES
                0034 # include "PROFILES_SIZE.h"
                0035 # include "profiles.h"
                0036 #endif
ad59256d7d aver*0037 #ifdef ALLOW_OBSFIT
                0038 # include "OBSFIT_SIZE.h"
                0039 # include "OBSFIT.h"
                0040 #endif
                0041
69361556c2 Mart*0042 C     !INPUT/OUTPUT PARAMETERS:
                0043 C     myThid ::  my Thread Id number
7883e4f1a1 Jean*0044       INTEGER myThid
69361556c2 Mart*0045 CEOP
2dcaa8b9a5 Patr*0046
bbf42b7711 Patr*0047 #ifdef ALLOW_COST
69361556c2 Mart*0048 C     !FUNCTIONS:
                0049       LOGICAL  MASTER_CPU_THREAD
                0050       EXTERNAL MASTER_CPU_THREAD
                0051
                0052 C     !LOCAL VARIABLES:
7883e4f1a1 Jean*0053       INTEGER bi,bj
                0054       _RL glob_fc, loc_fc
69361556c2 Mart*0055 #ifndef ALLOW_CTRL
                0056 C     dummy parameter for this unlikely case
                0057       INTEGER optimcycle
ad59256d7d aver*0058 #endif
69361556c2 Mart*0059       INTEGER ifc
                0060       INTEGER ioUnit
                0061       CHARACTER*17 cfname
3bafcf6020 Timo*0062       CHARACTER*(MAX_LEN_MBUF) msgBuf
2dcaa8b9a5 Patr*0063
69361556c2 Mart*0064       ioUnit = standardMessageUnit
                0065       WRITE(msgBuf,'(A)')
                0066      &  '// ======================================================='
                0067       CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0068       WRITE(msgBuf,'(A)') '// Start of S/R COST_FINAL'
                0069       CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0070       WRITE(msgBuf,'(A)')
                0071      &  '// ======================================================='
                0072       CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0073
                0074 #ifndef ALLOW_CTRL
                0075 C     dummy value for this unlikely case
                0076       optimcycle = 0
                0077 #endif
                0078
                0079 C     ifc = -1 means: do not write output to a file costfunction_${PKG}.XXXX
                0080       ifc = -1
                0081       IF ( MASTER_CPU_THREAD(myThid) .AND. costWriteCostFunction ) THEN
                0082        CALL MDSFINDUNIT( ifc, myThid )
                0083       ENDIF
2dcaa8b9a5 Patr*0084
869864d4b6 Patr*0085 #ifdef ALLOW_SEAICE
69361556c2 Mart*0086       IF (useSEAICE) CALL SEAICE_COST_FINAL( ifc, optimcycle, myThid )
869864d4b6 Patr*0087 #endif
                0088
1d6fceaddf Mart*0089 #ifdef ALLOW_SHELFICE
69361556c2 Mart*0090       IF (useShelfice)
                0091      &     CALL SHELFICE_COST_FINAL( ifc, optimcycle, myThid )
96b006450c dngo*0092 #endif
                0093
                0094 #if (defined(ALLOW_STREAMICE) && defined(ALLOW_COST_STREAMICE))
69361556c2 Mart*0095       IF (useStreamice) CALL STREAMICE_COST_FINAL( myThid )
1d6fceaddf Mart*0096 #endif
                0097
6c747cb1b2 Patr*0098 #ifdef ALLOW_THSICE
69361556c2 Mart*0099       IF (useThSIce) CALL THSICE_COST_FINAL( ifc, optimcycle, myThid )
6c747cb1b2 Patr*0100 #endif
                0101
98264b2c3d Gael*0102 #ifdef ALLOW_ECCO
69361556c2 Mart*0103       IF (useECCO) CALL ECCO_COST_FINAL( ifc, optimcycle, myThid )
                0104 #endif
                0105
                0106 #ifdef ALLOW_PROFILES
                0107       IF (usePROFILES)
                0108      &     CALL PROFILES_COST_FINAL( ifc, optimcycle, myThid )
                0109 #endif
                0110
                0111 #ifdef ALLOW_OBSFIT
                0112       IF (useOBSFIT) CALL OBSFIT_COST_FINAL( ifc, optimcycle, myThid )
                0113 #endif
                0114
                0115 #ifdef ALLOW_CTRL
                0116       IF (useCTRL) CALL CTRL_COST_FINAL( ifc, optimcycle, myThid )
                0117 #endif
                0118
                0119 #ifdef ALLOW_OBCS
                0120       IF (useOBCS) CALL OBCS_COST_FINAL( ifc, optimcycle, myThid )
98264b2c3d Gael*0121 #endif
720be40b89 Patr*0122
98264b2c3d Gael*0123 #ifdef ALLOW_COST_STATE_FINAL
69361556c2 Mart*0124       CALL COST_STATE_FINAL( myThid )
5ed655852f Jean*0125 cgf : effectively using this in adjoint requires the
98264b2c3d Gael*0126 c     use of adjoint_state_final. That will activate the
                0127 c     objf_state_final vector in place of the fc scalar.
                0128 c     objf_state_final is therefore not added to fc.
                0129 #endif
720be40b89 Patr*0130
98264b2c3d Gael*0131 #ifdef ALLOW_COST_VECTOR
                0132 cgf : same idea as for ALLOW_COST_STATE_FINAL
69361556c2 Mart*0133       CALL COST_VECTOR( myThid )
98264b2c3d Gael*0134 #endif
720be40b89 Patr*0135
2f1693fad8 Patr*0136 # ifdef ALLOW_COST_TEST
69361556c2 Mart*0137       CALL COST_TEST( myThid )
2f1693fad8 Patr*0138 # endif
98264b2c3d Gael*0139
2f1693fad8 Patr*0140 # ifdef ALLOW_COST_ATLANTIC_HEAT
69361556c2 Mart*0141       CALL COST_ATLANTIC_HEAT( myThid )
2f1693fad8 Patr*0142 # endif
98264b2c3d Gael*0143
913151f332 Davi*0144 #ifdef ALLOW_COST_HFLUXM
69361556c2 Mart*0145       CALL COST_HFLUX( myThid )
3bafcf6020 Timo*0146 cgf : to compile previous line user is expected to provide cost_hflux.F
913151f332 Davi*0147 #endif
98264b2c3d Gael*0148
913151f332 Davi*0149 #ifdef ALLOW_COST_TEMP
69361556c2 Mart*0150       CALL COST_TEMP( myThid )
98264b2c3d Gael*0151 cgf : to compile previous line user is expected to provide cost_temp.F
913151f332 Davi*0152 #endif
720be40b89 Patr*0153
69361556c2 Mart*0154       WRITE(msgBuf,'(A,1PE22.14)') '  early fc = ', fc
                0155       CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
11c3150c71 Mart*0156
69361556c2 Mart*0157 c--   Sum up all other contributions.
7883e4f1a1 Jean*0158       loc_fc = 0.
                0159       DO bj = myByLo(myThid), myByHi(myThid)
                0160        DO bi = myBxLo(myThid), myBxHi(myThid)
2dcaa8b9a5 Patr*0161
a9ded497a5 Gael*0162 #ifdef ALLOW_COST_TEST
69361556c2 Mart*0163         WRITE(UNIT=ioUnit,FMT='(A,1PE22.14,1X,1PE9.2)')
                0164      &       ' --> objf_test(bi,bj)      = ',
                0165      &       objf_test(bi,bj), mult_test
a9ded497a5 Gael*0166 #endif
                0167 #ifdef ALLOW_COST_TRACER
69361556c2 Mart*0168         WRITE(UNIT=ioUnit,FMT='(A,1PE22.14,1X,1PE9.2)')
                0169      &       ' --> objf_tracer(bi,bj)    = ',
                0170      &       objf_tracer(bi,bj), mult_tracer
a9ded497a5 Gael*0171 #endif
cda1c18f72 Jean*0172 #ifdef ALLOW_COST_ATLANTIC_HEAT
69361556c2 Mart*0173         WRITE(UNIT=ioUnit,FMT='(A,1PE22.14,1X,1PE9.2)')
                0174      &       ' --> objf_atl(bi,bj)       = ',
                0175      &       objf_atl(bi,bj), mult_atl
98264b2c3d Gael*0176 #endif
913151f332 Davi*0177 #ifdef ALLOW_COST_TEMP
69361556c2 Mart*0178         WRITE(UNIT=ioUnit,FMT='(A,1PE22.14,1X,1PE9.2)')
                0179      &       ' --> objf_temp_tut(bi,bj)  = ',
                0180      &       objf_temp_tut(bi,bj), mult_temp_tut
913151f332 Davi*0181 #endif
                0182 #ifdef ALLOW_COST_HFLUXM
69361556c2 Mart*0183         WRITE(UNIT=ioUnit,FMT='(A,1PE22.14,1X,1PE9.2)')
                0184      &       ' --> objf_hflux_tut(bi,bj) = ',
                0185      &       objf_hflux_tut(bi,bj), mult_hflux_tut
11c3150c71 Mart*0186 #endif
2dcaa8b9a5 Patr*0187
7883e4f1a1 Jean*0188          tile_fc(bi,bj) = tile_fc(bi,bj)
a9ded497a5 Gael*0189 #ifdef ALLOW_COST_TEST
bbf42b7711 Patr*0190      &            + mult_test   * objf_test(bi,bj)
a9ded497a5 Gael*0191 #endif
                0192 #ifdef ALLOW_COST_TRACER
bbf42b7711 Patr*0193      &            + mult_tracer * objf_tracer(bi,bj)
a9ded497a5 Gael*0194 #endif
cda1c18f72 Jean*0195 #ifdef ALLOW_COST_ATLANTIC_HEAT
720be40b89 Patr*0196      &            + mult_atl    * objf_atl(bi,bj)
616600b8d2 Patr*0197 #endif
913151f332 Davi*0198 #ifdef ALLOW_COST_TEMP
14021e1fda Davi*0199      &            + mult_temp_tut  * objf_temp_tut(bi,bj)
913151f332 Davi*0200 #endif
                0201 #ifdef ALLOW_COST_HFLUXM
14021e1fda Davi*0202      &            + mult_hflux_tut * objf_hflux_tut(bi,bj)
913151f332 Davi*0203 #endif
8f14b8ea71 Gael*0204
7883e4f1a1 Jean*0205          loc_fc = loc_fc + tile_fc(bi,bj)
8f14b8ea71 Gael*0206
7883e4f1a1 Jean*0207        ENDDO
                0208       ENDDO
2dcaa8b9a5 Patr*0209
69361556c2 Mart*0210       WRITE(msgBuf,'(A,1PE22.14)') '  local fc = ', loc_fc
                0211       CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
2dcaa8b9a5 Patr*0212
                0213 c--   Do global summation.
7883e4f1a1 Jean*0214       CALL GLOBAL_SUM_TILE_RL( tile_fc, glob_fc, myThid )
                0215       _BEGIN_MASTER( myThid )
                0216       fc = fc + glob_fc
2dcaa8b9a5 Patr*0217
69361556c2 Mart*0218 c--   Add contributions from global mean constraints (includes pkg/obsfit)
7883e4f1a1 Jean*0219       fc = fc + glofc
                0220       _END_MASTER( myThid )
8a270036d8 Gael*0221
a35895498f Patr*0222 #ifdef ALLOW_DIC_COST
ade85a36e7 Patr*0223 cph-- quickly for testing
                0224       fc = totcost
                0225 #endif
                0226
69361556c2 Mart*0227       IF ( ifc .NE. -1 ) THEN
                0228        WRITE(cfname,'(A,I4.4)') 'costfunction.',optimcycle
                0229        WRITE(msgBuf,'(A,A)')
                0230      &      'Writing global cost function info to ', cfname
                0231        CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0232        OPEN(UNIT=ifc,FILE=cfname)
                0233        WRITE(UNIT=ifc,FMT='(A,1PE22.14)') 'fc =', fc
                0234 C     Collect and copy other cost function contributions in a separate
                0235 C     file to hide irreducible statements from TAF
                0236        CALL COST_COPY_FILE(ifc, optimcycle, myThid)
                0237
                0238        CLOSE(ifc)
                0239 C     Do not ever write this cost function again to cfname
                0240        costWriteCostFunction = .FALSE.
                0241       ENDIF
                0242
                0243       WRITE(msgBuf,'(A,1PE22.14)') ' global fc = ', fc
                0244       CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0245
                0246       WRITE(msgBuf,'(A)')
                0247      &  '// ======================================================='
                0248       CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0249       WRITE(msgBuf,'(A)') '// End of S/R COST_FINAL'
                0250       CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0251       WRITE(msgBuf,'(A)')
                0252      &  '// ======================================================='
                0253       CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
9eb96e5404 Patr*0254
2a878d427b Jean*0255 c--   to avoid re-write of output in reverse checkpointing loops,
                0256 c--   switch off output flag :
                0257       CALL TURNOFF_MODEL_IO( 0, myThid )
c28cf14cd7 Patr*0258
bbf42b7711 Patr*0259 #endif /* ALLOW_COST */
2dcaa8b9a5 Patr*0260
3bafcf6020 Timo*0261       RETURN
                0262       END