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
7883e4f1a1 Jean*0006       SUBROUTINE COST_FINAL( myThid )
2dcaa8b9a5 Patr*0007
                0008 c     ==================================================================
720be40b89 Patr*0009 c     SUBROUTINE cost_final
2dcaa8b9a5 Patr*0010 c     ==================================================================
                0011 c
                0012 c     o Sum of all cost function contributions.
                0013 c
                0014 c     ==================================================================
720be40b89 Patr*0015 c     SUBROUTINE cost_final
2dcaa8b9a5 Patr*0016 c     ==================================================================
                0017
7883e4f1a1 Jean*0018       IMPLICIT NONE
2dcaa8b9a5 Patr*0019
                0020 c     == global variables ==
                0021 #include "EEPARAMS.h"
                0022 #include "SIZE.h"
c28cf14cd7 Patr*0023 #include "PARAMS.h"
2dcaa8b9a5 Patr*0024
                0025 #include "cost.h"
9829fd7e0c Patr*0026 #ifdef ALLOW_CTRL
5cf4364659 Mart*0027 # include "CTRL_SIZE.h"
4d72283393 Mart*0028 # include "CTRL.h"
9829fd7e0c Patr*0029 #endif
ade85a36e7 Patr*0030 #ifdef ALLOW_DIC
                0031 # include "DIC_COST.h"
                0032 #endif
64c318b5ee Patr*0033 #ifdef ALLOW_COST_SHELFICE
                0034 # include "SHELFICE_COST.h"
                0035 #endif
                0036
8f14b8ea71 Gael*0037 #ifdef ALLOW_PROFILES
                0038 # include "PROFILES_SIZE.h"
                0039 # include "profiles.h"
                0040 #endif
                0041
2dcaa8b9a5 Patr*0042 c     == routine arguments ==
7883e4f1a1 Jean*0043       INTEGER myThid
2dcaa8b9a5 Patr*0044
bbf42b7711 Patr*0045 #ifdef ALLOW_COST
2dcaa8b9a5 Patr*0046 c     == local variables ==
7883e4f1a1 Jean*0047       INTEGER bi,bj
                0048       _RL glob_fc, loc_fc
8f14b8ea71 Gael*0049 #ifdef ALLOW_PROFILES
3bafcf6020 Timo*0050       INTEGER num_file,num_var
8f14b8ea71 Gael*0051 #endif
3bafcf6020 Timo*0052       CHARACTER*(MAX_LEN_MBUF) msgBuf
2dcaa8b9a5 Patr*0053
                0054 c     == end of interface ==
                0055
869864d4b6 Patr*0056 #ifdef ALLOW_SEAICE
2b959ba38e Mart*0057       IF (useSEAICE) CALL SEAICE_COST_FINAL( myThid )
869864d4b6 Patr*0058 #endif
                0059
1d6fceaddf Mart*0060 #ifdef ALLOW_SHELFICE
3bafcf6020 Timo*0061       IF (useShelfice) CALL SHELFICE_COST_FINAL (myThid)
96b006450c dngo*0062 #endif
                0063
                0064 #if (defined(ALLOW_STREAMICE) && defined(ALLOW_COST_STREAMICE))
                0065       IF (useStreamice) CALL STREAMICE_COST_FINAL (myThid)
1d6fceaddf Mart*0066 #endif
                0067
6c747cb1b2 Patr*0068 #ifdef ALLOW_THSICE
eaa2114d11 Jean*0069       IF (useThSIce) CALL THSICE_COST_FINAL (myThid)
6c747cb1b2 Patr*0070 #endif
                0071
98264b2c3d Gael*0072 #ifdef ALLOW_ECCO
8f14b8ea71 Gael*0073       IF (useECCO) CALL ECCO_COST_FINAL (myThid)
98264b2c3d Gael*0074 #endif
720be40b89 Patr*0075
98264b2c3d Gael*0076 #ifdef ALLOW_COST_STATE_FINAL
9eb96e5404 Patr*0077       CALL COST_STATE_FINAL (myThid)
5ed655852f Jean*0078 cgf : effectively using this in adjoint requires the
98264b2c3d Gael*0079 c     use of adjoint_state_final. That will activate the
                0080 c     objf_state_final vector in place of the fc scalar.
                0081 c     objf_state_final is therefore not added to fc.
                0082 #endif
720be40b89 Patr*0083
98264b2c3d Gael*0084 #ifdef ALLOW_COST_VECTOR
                0085 cgf : same idea as for ALLOW_COST_STATE_FINAL
                0086       CALL COST_VECTOR (myThid)
                0087 #endif
720be40b89 Patr*0088
2f1693fad8 Patr*0089 # ifdef ALLOW_COST_TEST
bbf42b7711 Patr*0090       CALL COST_TEST (myThid)
2f1693fad8 Patr*0091 # endif
98264b2c3d Gael*0092
2f1693fad8 Patr*0093 # ifdef ALLOW_COST_ATLANTIC_HEAT
720be40b89 Patr*0094       CALL COST_ATLANTIC_HEAT (myThid)
2f1693fad8 Patr*0095 # endif
98264b2c3d Gael*0096
913151f332 Davi*0097 #ifdef ALLOW_COST_HFLUXM
                0098       CALL COST_HFLUX (myThid)
3bafcf6020 Timo*0099 cgf : to compile previous line user is expected to provide cost_hflux.F
913151f332 Davi*0100 #endif
98264b2c3d Gael*0101
913151f332 Davi*0102 #ifdef ALLOW_COST_TEMP
                0103       CALL COST_TEMP (myThid)
98264b2c3d Gael*0104 cgf : to compile previous line user is expected to provide cost_temp.F
913151f332 Davi*0105 #endif
720be40b89 Patr*0106
11c3150c71 Mart*0107 #ifdef ALLOW_COST_DEPTH
                0108       CALL COST_DEPTH( myThid )
                0109 #endif
                0110
3bafcf6020 Timo*0111       WRITE(msgBuf,'(A,D22.15)') '  early fc = ', fc
                0112       CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0113      &                    SQUEEZE_RIGHT, myThid )
7883e4f1a1 Jean*0114
2dcaa8b9a5 Patr*0115 c--   Sum up all contributions.
7883e4f1a1 Jean*0116       loc_fc = 0.
                0117       DO bj = myByLo(myThid), myByHi(myThid)
                0118        DO bi = myBxLo(myThid), myBxHi(myThid)
2dcaa8b9a5 Patr*0119
a9ded497a5 Gael*0120 #ifdef ALLOW_COST_TEST
3bafcf6020 Timo*0121          WRITE(standardMessageUnit,'(A,D22.15)')
11c3150c71 Mart*0122      &       ' --> objf_test(bi,bj)        = ', objf_test(bi,bj)
a9ded497a5 Gael*0123 #endif
                0124 #ifdef ALLOW_COST_TRACER
3bafcf6020 Timo*0125          WRITE(standardMessageUnit,'(A,D22.15)')
11c3150c71 Mart*0126      &         ' --> objf_tracer(bi,bj)    = ', objf_tracer(bi,bj)
a9ded497a5 Gael*0127 #endif
cda1c18f72 Jean*0128 #ifdef ALLOW_COST_ATLANTIC_HEAT
3bafcf6020 Timo*0129          WRITE(standardMessageUnit,'(A,D22.15)')
11c3150c71 Mart*0130      &         ' --> objf_atl(bi,bj)       = ', objf_atl(bi,bj)
98264b2c3d Gael*0131 #endif
913151f332 Davi*0132 #ifdef ALLOW_COST_TEMP
3bafcf6020 Timo*0133          WRITE(standardMessageUnit,'(A,D22.15)')
11c3150c71 Mart*0134      &         ' --> objf_temp_tut(bi,bj)  = ', objf_temp_tut(bi,bj)
913151f332 Davi*0135 #endif
                0136 #ifdef ALLOW_COST_HFLUXM
3bafcf6020 Timo*0137          WRITE(standardMessageUnit,'(A,D22.15)')
14021e1fda Davi*0138      &         ' --> objf_hflux_tut(bi,bj) = ', objf_hflux_tut(bi,bj)
913151f332 Davi*0139 #endif
11c3150c71 Mart*0140 #ifdef ALLOW_COST_DEPTH
3bafcf6020 Timo*0141          WRITE(standardMessageUnit,'(A,D22.15)')
11c3150c71 Mart*0142      &         ' --> objf_depth(bi,bj)     = ', objf_depth(bi,bj)
                0143 #endif
2dcaa8b9a5 Patr*0144
7883e4f1a1 Jean*0145          tile_fc(bi,bj) = tile_fc(bi,bj)
a9ded497a5 Gael*0146 #ifdef ALLOW_COST_TEST
bbf42b7711 Patr*0147      &            + mult_test   * objf_test(bi,bj)
a9ded497a5 Gael*0148 #endif
                0149 #ifdef ALLOW_COST_TRACER
bbf42b7711 Patr*0150      &            + mult_tracer * objf_tracer(bi,bj)
a9ded497a5 Gael*0151 #endif
cda1c18f72 Jean*0152 #ifdef ALLOW_COST_ATLANTIC_HEAT
720be40b89 Patr*0153      &            + mult_atl    * objf_atl(bi,bj)
616600b8d2 Patr*0154 #endif
913151f332 Davi*0155 #ifdef ALLOW_COST_TEMP
14021e1fda Davi*0156      &            + mult_temp_tut  * objf_temp_tut(bi,bj)
913151f332 Davi*0157 #endif
                0158 #ifdef ALLOW_COST_HFLUXM
14021e1fda Davi*0159      &            + mult_hflux_tut * objf_hflux_tut(bi,bj)
913151f332 Davi*0160 #endif
11c3150c71 Mart*0161 #ifdef ALLOW_COST_DEPTH
                0162      &            + mult_depth     * objf_depth(bi,bj)
                0163 #endif
8f14b8ea71 Gael*0164
                0165 #ifdef ALLOW_PROFILES
3bafcf6020 Timo*0166          IF (.NOT.useECCO) THEN
                0167           DO num_file=1,NFILESPROFMAX
                0168            DO num_var=1,NVARMAX
                0169             tile_fc(bi,bj) = tile_fc(bi,bj)
8f14b8ea71 Gael*0170      &            + mult_profiles(num_file,num_var)
                0171      &            *objf_profiles(num_file,num_var,bi,bj)
3bafcf6020 Timo*0172            ENDDO
                0173           ENDDO
                0174          ENDIF
8f14b8ea71 Gael*0175 #endif
                0176
7883e4f1a1 Jean*0177          loc_fc = loc_fc + tile_fc(bi,bj)
8f14b8ea71 Gael*0178
7883e4f1a1 Jean*0179        ENDDO
                0180       ENDDO
2dcaa8b9a5 Patr*0181
3bafcf6020 Timo*0182       WRITE(msgBuf,'(A,D22.15)') '  local fc = ', loc_fc
                0183       CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0184      &                    SQUEEZE_RIGHT, myThid )
2dcaa8b9a5 Patr*0185
                0186 c--   Do global summation.
7883e4f1a1 Jean*0187       CALL GLOBAL_SUM_TILE_RL( tile_fc, glob_fc, myThid )
                0188       _BEGIN_MASTER( myThid )
                0189       fc = fc + glob_fc
                0190       _END_MASTER( myThid )
2dcaa8b9a5 Patr*0191
8a270036d8 Gael*0192 c--   Add contributions from global mean constraints
7883e4f1a1 Jean*0193       _BEGIN_MASTER( myThid )
                0194       fc = fc + glofc
                0195       _END_MASTER( myThid )
8a270036d8 Gael*0196
a35895498f Patr*0197 #ifdef ALLOW_DIC_COST
ade85a36e7 Patr*0198 cph-- quickly for testing
                0199       fc = totcost
                0200 #endif
                0201
3bafcf6020 Timo*0202       WRITE(msgBuf,'(A,D22.15)') ' global fc = ', fc
                0203       CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0204      &                    SQUEEZE_RIGHT, myThid )
9eb96e5404 Patr*0205
2a878d427b Jean*0206 c--   to avoid re-write of output in reverse checkpointing loops,
                0207 c--   switch off output flag :
                0208       CALL TURNOFF_MODEL_IO( 0, myThid )
c28cf14cd7 Patr*0209
bbf42b7711 Patr*0210 #endif /* ALLOW_COST */
2dcaa8b9a5 Patr*0211
3bafcf6020 Timo*0212       RETURN
                0213       END