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
df0999b5dc Jean*0030 #if ( defined ALLOW_SHELFICE && defined ALLOW_COST_SHELFICE )
64c318b5ee Patr*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
df0999b5dc Jean*0061       CHARACTER*15 tile15c
69361556c2 Mart*0062       CHARACTER*17 cfname
3bafcf6020 Timo*0063       CHARACTER*(MAX_LEN_MBUF) msgBuf
2dcaa8b9a5 Patr*0064
69361556c2 Mart*0065       ioUnit = standardMessageUnit
                0066       WRITE(msgBuf,'(A)')
                0067      &  '// ======================================================='
                0068       CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0069       WRITE(msgBuf,'(A)') '// Start of S/R COST_FINAL'
                0070       CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0071       WRITE(msgBuf,'(A)')
                0072      &  '// ======================================================='
                0073       CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0074
                0075 #ifndef ALLOW_CTRL
                0076 C     dummy value for this unlikely case
                0077       optimcycle = 0
                0078 #endif
                0079
                0080 C     ifc = -1 means: do not write output to a file costfunction_${PKG}.XXXX
                0081       ifc = -1
                0082       IF ( MASTER_CPU_THREAD(myThid) .AND. costWriteCostFunction ) THEN
                0083        CALL MDSFINDUNIT( ifc, myThid )
                0084       ENDIF
2dcaa8b9a5 Patr*0085
df0999b5dc Jean*0086 C--   final cost from comparison-to-obs pkgs:
69361556c2 Mart*0087 #ifdef ALLOW_PROFILES
                0088       IF (usePROFILES)
                0089      &     CALL PROFILES_COST_FINAL( ifc, optimcycle, myThid )
                0090 #endif
                0091 #ifdef ALLOW_OBSFIT
                0092       IF (useOBSFIT) CALL OBSFIT_COST_FINAL( ifc, optimcycle, myThid )
                0093 #endif
                0094
df0999b5dc Jean*0095 C--   final cost from generic-cost pkg, i.e., pkg/ecco:
                0096 #ifdef ALLOW_ECCO
                0097       IF (useECCO) CALL ECCO_COST_FINAL( ifc, optimcycle, myThid )
                0098 #endif
                0099
                0100 C--   final cost from control (Tikhonov regularisation), i.e., ctrl & obcs:
69361556c2 Mart*0101 #ifdef ALLOW_CTRL
                0102       IF (useCTRL) CALL CTRL_COST_FINAL( ifc, optimcycle, myThid )
                0103 #endif
                0104 #ifdef ALLOW_OBCS
                0105       IF (useOBCS) CALL OBCS_COST_FINAL( ifc, optimcycle, myThid )
98264b2c3d Gael*0106 #endif
720be40b89 Patr*0107
df0999b5dc Jean*0108 C--   final cost from remaining individual pkgs:
                0109 #ifdef ALLOW_THSICE
                0110       IF (useThSIce) CALL THSICE_COST_FINAL( ifc, optimcycle, myThid )
                0111 #endif
                0112 #ifdef ALLOW_SEAICE
                0113       IF (useSEAICE) CALL SEAICE_COST_FINAL( ifc, optimcycle, myThid )
                0114 #endif
                0115 #if ( defined ALLOW_SHELFICE && defined ALLOW_COST_SHELFICE )
                0116       IF (useShelfIce)
                0117      &     CALL SHELFICE_COST_FINAL( ifc, optimcycle, myThid )
98264b2c3d Gael*0118 #endif
720be40b89 Patr*0119
df0999b5dc Jean*0120 #if ( defined ALLOW_STREAMICE && defined ALLOW_COST_STREAMICE )
                0121       IF (useStreamice) CALL STREAMICE_COST_FINAL( myThid )
98264b2c3d Gael*0122 #endif
720be40b89 Patr*0123
df0999b5dc Jean*0124 C--   final cost from customized/testing code:
2f1693fad8 Patr*0125 # ifdef ALLOW_COST_TEST
69361556c2 Mart*0126       CALL COST_TEST( myThid )
2f1693fad8 Patr*0127 # endif
98264b2c3d Gael*0128
2f1693fad8 Patr*0129 # ifdef ALLOW_COST_ATLANTIC_HEAT
69361556c2 Mart*0130       CALL COST_ATLANTIC_HEAT( myThid )
2f1693fad8 Patr*0131 # endif
98264b2c3d Gael*0132
913151f332 Davi*0133 #ifdef ALLOW_COST_HFLUXM
69361556c2 Mart*0134       CALL COST_HFLUX( myThid )
913151f332 Davi*0135 #endif
98264b2c3d Gael*0136
913151f332 Davi*0137 #ifdef ALLOW_COST_TEMP
69361556c2 Mart*0138       CALL COST_TEMP( myThid )
df0999b5dc Jean*0139 #endif
                0140
                0141 C--   final cost with alternative cost-function:
                0142 #ifdef ALLOW_COST_STATE_FINAL
                0143       CALL COST_STATE_FINAL( myThid )
                0144 Cgf : effectively using this in adjoint requires the use of adjoint_state_final.
                0145 C     That will activate the objf_state_final vector in place of the fc scalar.
                0146 C     objf_state_final is therefore not added to fc.
                0147 #endif
                0148
                0149 #ifdef ALLOW_COST_VECTOR
                0150 Cgf : same idea as for ALLOW_COST_STATE_FINAL
                0151       CALL COST_VECTOR( myThid )
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
df0999b5dc Jean*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)
df0999b5dc Jean*0161         WRITE(tile15c,'(2(A,I3),A)') '(bi,bj=', bi, ',', bj, ')'
2dcaa8b9a5 Patr*0162
a9ded497a5 Gael*0163 #ifdef ALLOW_COST_TEST
df0999b5dc Jean*0164         WRITE(ioUnit,'(3A,1PE22.14,1X,1PE9.2)')
                0165      &       ' --> objf_test     ', tile15c, ' =',
69361556c2 Mart*0166      &       objf_test(bi,bj), mult_test
a9ded497a5 Gael*0167 #endif
                0168 #ifdef ALLOW_COST_TRACER
df0999b5dc Jean*0169         WRITE(ioUnit,'(3A,1PE22.14,1X,1PE9.2)')
                0170      &       ' --> objf_tracer   ', tile15c, ' =',
69361556c2 Mart*0171      &       objf_tracer(bi,bj), mult_tracer
a9ded497a5 Gael*0172 #endif
cda1c18f72 Jean*0173 #ifdef ALLOW_COST_ATLANTIC_HEAT
df0999b5dc Jean*0174         WRITE(ioUnit,'(3A,1PE22.14,1X,1PE9.2)')
                0175      &       ' --> objf_atl      ', tile15c, ' =',
69361556c2 Mart*0176      &       objf_atl(bi,bj), mult_atl
98264b2c3d Gael*0177 #endif
913151f332 Davi*0178 #ifdef ALLOW_COST_TEMP
df0999b5dc Jean*0179         WRITE(ioUnit,'(3A,1PE22.14,1X,1PE9.2)')
                0180      &       ' --> objf_temp_tut ', tile15c, ' =',
69361556c2 Mart*0181      &       objf_temp_tut(bi,bj), mult_temp_tut
913151f332 Davi*0182 #endif
                0183 #ifdef ALLOW_COST_HFLUXM
df0999b5dc Jean*0184         WRITE(ioUnit,'(3A,1PE22.14,1X,1PE9.2)')
                0185      &       ' --> objf_hflux_tut', tile15c, ' =',
69361556c2 Mart*0186      &       objf_hflux_tut(bi,bj), mult_hflux_tut
11c3150c71 Mart*0187 #endif
2dcaa8b9a5 Patr*0188
7883e4f1a1 Jean*0189          tile_fc(bi,bj) = tile_fc(bi,bj)
a9ded497a5 Gael*0190 #ifdef ALLOW_COST_TEST
bbf42b7711 Patr*0191      &            + mult_test   * objf_test(bi,bj)
a9ded497a5 Gael*0192 #endif
                0193 #ifdef ALLOW_COST_TRACER
bbf42b7711 Patr*0194      &            + mult_tracer * objf_tracer(bi,bj)
a9ded497a5 Gael*0195 #endif
cda1c18f72 Jean*0196 #ifdef ALLOW_COST_ATLANTIC_HEAT
720be40b89 Patr*0197      &            + mult_atl    * objf_atl(bi,bj)
616600b8d2 Patr*0198 #endif
913151f332 Davi*0199 #ifdef ALLOW_COST_TEMP
14021e1fda Davi*0200      &            + mult_temp_tut  * objf_temp_tut(bi,bj)
913151f332 Davi*0201 #endif
                0202 #ifdef ALLOW_COST_HFLUXM
14021e1fda Davi*0203      &            + mult_hflux_tut * objf_hflux_tut(bi,bj)
913151f332 Davi*0204 #endif
8f14b8ea71 Gael*0205
7883e4f1a1 Jean*0206          loc_fc = loc_fc + tile_fc(bi,bj)
8f14b8ea71 Gael*0207
7883e4f1a1 Jean*0208        ENDDO
                0209       ENDDO
2dcaa8b9a5 Patr*0210
69361556c2 Mart*0211       WRITE(msgBuf,'(A,1PE22.14)') '  local fc = ', loc_fc
                0212       CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
2dcaa8b9a5 Patr*0213
df0999b5dc Jean*0214 C--   Do global summation.
7883e4f1a1 Jean*0215       CALL GLOBAL_SUM_TILE_RL( tile_fc, glob_fc, myThid )
                0216       _BEGIN_MASTER( myThid )
                0217       fc = fc + glob_fc
2dcaa8b9a5 Patr*0218
df0999b5dc Jean*0219 C--   Add contributions from global mean constraints (includes pkg/obsfit)
7883e4f1a1 Jean*0220       fc = fc + glofc
                0221       _END_MASTER( myThid )
8a270036d8 Gael*0222
df0999b5dc Jean*0223 #if ( defined ALLOW_DIC && defined ALLOW_DIC_COST )
                0224 Cph-- quickly for testing
ade85a36e7 Patr*0225       fc = totcost
                0226 #endif
                0227
69361556c2 Mart*0228       IF ( ifc .NE. -1 ) THEN
                0229        WRITE(cfname,'(A,I4.4)') 'costfunction.',optimcycle
                0230        WRITE(msgBuf,'(A,A)')
                0231      &      'Writing global cost function info to ', cfname
                0232        CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0233        OPEN(UNIT=ifc,FILE=cfname)
df0999b5dc Jean*0234        WRITE(ifc,'(A,1PE22.14)') 'fc =', fc
69361556c2 Mart*0235 C     Collect and copy other cost function contributions in a separate
                0236 C     file to hide irreducible statements from TAF
df0999b5dc Jean*0237        CALL COST_COPY_FILE( ifc, optimcycle, myThid )
69361556c2 Mart*0238
                0239        CLOSE(ifc)
                0240 C     Do not ever write this cost function again to cfname
                0241        costWriteCostFunction = .FALSE.
                0242       ENDIF
                0243
                0244       WRITE(msgBuf,'(A,1PE22.14)') ' global fc = ', fc
                0245       CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0246
                0247       WRITE(msgBuf,'(A)')
                0248      &  '// ======================================================='
                0249       CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0250       WRITE(msgBuf,'(A)') '// End of S/R COST_FINAL'
                0251       CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
                0252       WRITE(msgBuf,'(A)')
                0253      &  '// ======================================================='
                0254       CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
9eb96e5404 Patr*0255
df0999b5dc Jean*0256 C--   to avoid re-write of output in reverse checkpointing loops,
                0257 C--   switch off output flag :
2a878d427b Jean*0258       CALL TURNOFF_MODEL_IO( 0, myThid )
c28cf14cd7 Patr*0259
bbf42b7711 Patr*0260 #endif /* ALLOW_COST */
2dcaa8b9a5 Patr*0261
3bafcf6020 Timo*0262       RETURN
                0263       END