pkg/ctrl/ctrl_cost_final.F

69361556c2 Mart*0001 #include "CTRL_OPTIONS.h"
                0002 #ifdef ALLOW_COST
                0003 #include "COST_OPTIONS.h"
                0004 #endif
                0005
                0006 CBOP
                0007 C     !ROUTINE: CTRL_COST_FINAL
                0008 C     !INTERFACE:
                0009       SUBROUTINE CTRL_COST_FINAL( ifc, optimcycle, myThid )
                0010
                0011 C     !DESCRIPTION:
                0012 C     *==========================================================*
                0013 C     | SUBROUTINE CTRL_COST_FINAL
                0014 C     *==========================================================*
                0015
                0016 C     !USES:
                0017       IMPLICIT NONE
                0018
                0019 C     == global variables ==
                0020 #include "EEPARAMS.h"
                0021 #include "SIZE.h"
                0022 #include "PARAMS.h"
                0023 #ifdef ALLOW_COST
                0024 # include "cost.h"
                0025 #endif
                0026 #include "CTRL_SIZE.h"
                0027 #include "CTRL.h"
                0028 #include "CTRL_GENARR.h"
                0029
                0030 C     !INPUT/OUTPUT PARAMETERS:
                0031 C     ifc        :: file unit for costfunction_ctrl.XXXX
                0032 C     optimcycle :: cycle number of the off-line optimization.
                0033 C     myThid     :: my Thread Id number
                0034       INTEGER ifc
                0035       INTEGER optimcycle
                0036       INTEGER myThid
                0037
                0038 #if defined ALLOW_COST && ( defined ALLOW_GENTIM2D_CONTROL || \
                0039                             defined ALLOW_GENARR2D_CONTROL || \
                0040                             defined ALLOW_GENARR3D_CONTROL )
                0041 C     ! FUNCTIONS:
                0042       INTEGER  ILNBLNK
                0043       EXTERNAL ILNBLNK
                0044
                0045 C     !LOCAL VARIABLES:
                0046       INTEGER bi, bj, num_var
                0047 # ifdef ALLOW_GENTIM2D_CONTROL
                0048       _RL f_gentim2d(maxCtrlTim2D)
                0049       _RL no_gentim2d(maxCtrlTim2D)
                0050 # endif
                0051 # ifdef ALLOW_GENARR2D_CONTROL
                0052       _RL f_genarr2d(maxCtrlArr2D)
                0053       _RL no_genarr2d(maxCtrlArr2D)
                0054 # endif
                0055 # ifdef ALLOW_GENARR3D_CONTROL
                0056       _RL f_genarr3d(maxCtrlArr3D)
                0057       _RL no_genarr3d(maxCtrlArr3D)
                0058 # endif
                0059
                0060       CHARACTER*23 cfname
                0061       INTEGER IL
                0062       CHARACTER*(MAX_LEN_FNAM) xx_fname_loc
                0063       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0064 CEOP
                0065
                0066       IF ( useCtrlCostContribution ) THEN
                0067
                0068 C     Initialise cost function variables zo zero
                0069 # ifdef ALLOW_GENTIM2D_CONTROL
                0070        DO num_var=1,maxCtrlTim2D
                0071         f_gentim2d(num_var)= 0. _d 0
                0072         no_gentim2d(num_var)= 0. _d 0
                0073        ENDDO
                0074 # endif
                0075 # ifdef ALLOW_GENARR2D_CONTROL
                0076        DO num_var=1,maxCtrlArr2D
                0077         f_genarr2d(num_var)= 0. _d 0
                0078         no_genarr2d(num_var)= 0. _d 0
                0079        ENDDO
                0080 # endif
                0081 # ifdef ALLOW_GENARR3D_CONTROL
                0082        DO num_var=1,maxCtrlArr3D
                0083         f_genarr3d(num_var)= 0. _d 0
                0084         no_genarr3d(num_var)= 0. _d 0
                0085        ENDDO
                0086 # endif
                0087
                0088        DO bj = myByLo(myThid), myByHi(myThid)
                0089         DO bi = myBxLo(myThid), myBxHi(myThid)
                0090 # ifdef ALLOW_GENTIM2D_CONTROL
                0091          DO num_var=1,maxCtrlTim2D
                0092           tile_fc(bi,bj) = tile_fc(bi,bj)
                0093      &         + mult_gentim2d(num_var)
                0094      &         *objf_gentim2d(bi,bj,num_var)
                0095           f_gentim2d(num_var) = f_gentim2d(num_var)
                0096      &         +objf_gentim2d(bi,bj,num_var)
                0097           no_gentim2d(num_var) = no_gentim2d(num_var)
                0098      &         +num_gentim2d(bi,bj,num_var)
                0099          ENDDO
                0100 # endif
                0101 # ifdef ALLOW_GENARR2D_CONTROL
                0102          DO num_var=1,maxCtrlArr2D
                0103           tile_fc(bi,bj) = tile_fc(bi,bj)
                0104      &         + mult_genarr2d(num_var)
                0105      &         *objf_genarr2d(bi,bj,num_var)
                0106           f_genarr2d(num_var) = f_genarr2d(num_var)
                0107      &         +objf_genarr2d(bi,bj,num_var)
                0108           no_genarr2d(num_var) = no_genarr2d(num_var)
                0109      &         +num_genarr2d(bi,bj,num_var)
                0110          ENDDO
                0111 # endif
                0112 # ifdef ALLOW_GENARR3D_CONTROL
                0113          DO num_var=1,maxCtrlArr3D
                0114           tile_fc(bi,bj) = tile_fc(bi,bj)
                0115      &         + mult_genarr3d(num_var)
                0116      &         *objf_genarr3d(bi,bj,num_var)
                0117           f_genarr3d(num_var) = f_genarr3d(num_var)
                0118      &         +objf_genarr3d(bi,bj,num_var)
                0119           no_genarr3d(num_var) = no_genarr3d(num_var)
                0120      &         +num_genarr3d(bi,bj,num_var)
                0121          ENDDO
                0122 # endif
                0123         ENDDO
                0124        ENDDO
                0125
                0126 c#ifndef ALLOW_OPENAD
                0127 # ifdef ALLOW_GENTIM2D_CONTROL
                0128        DO num_var=1,maxCtrlTim2D
                0129         _GLOBAL_SUM_RL(f_gentim2d(num_var), myThid )
                0130         _GLOBAL_SUM_RL(no_gentim2d(num_var), myThid )
                0131         IF (no_gentim2d(num_var).GT.0. _d 0) THEN
                0132          xx_fname_loc = xx_gentim2d_file(num_var)
                0133          IL  = ILNBLNK( xx_fname_loc )
                0134          WRITE(msgBuf,'(A,1PE22.14,I2,1X,1PE9.2,1X,3A)')
                0135      &        ' --> f_gentim2d =',f_gentim2d(num_var), num_var,
                0136      &        mult_gentim2d(num_var), '(', xx_fname_loc(1:IL), ')'
                0137          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0138      &                       SQUEEZE_RIGHT, myThid )
                0139         ENDIF
                0140        ENDDO
                0141 # endif
                0142 # ifdef ALLOW_GENARR2D_CONTROL
                0143        DO num_var=1,maxCtrlArr2D
                0144         _GLOBAL_SUM_RL(f_genarr2d(num_var), myThid )
                0145         _GLOBAL_SUM_RL(no_genarr2d(num_var), myThid )
                0146         IF (no_genarr2d(num_var).GT.0. _d 0) THEN
                0147          xx_fname_loc = xx_genarr2d_file(num_var)
                0148          IL  = ILNBLNK( xx_fname_loc )
                0149          WRITE(msgBuf,'(A,1PE22.14,I2,1X,1PE9.2,1X,3A)')
                0150      &        ' --> f_genarr2d =',f_genarr2d(num_var), num_var,
                0151      &        mult_genarr2d(num_var), '(', xx_fname_loc(1:IL), ')'
                0152          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0153      &                       SQUEEZE_RIGHT, myThid )
                0154         ENDIF
                0155        ENDDO
                0156 # endif
                0157 # ifdef ALLOW_GENARR3D_CONTROL
                0158        DO num_var=1,maxCtrlArr3D
                0159         _GLOBAL_SUM_RL(f_genarr3d(num_var), myThid )
                0160         _GLOBAL_SUM_RL(no_genarr3d(num_var), myThid )
                0161         IF (no_genarr3d(num_var).GT.0. _d 0) THEN
                0162          xx_fname_loc = xx_genarr3d_file(num_var)
                0163          IL  = ILNBLNK( xx_fname_loc )
                0164          WRITE(msgBuf,'(A,1PE22.14,I2,1X,1PE9.2,1X,3A)')
                0165      &        ' --> f_genarr3d =',f_genarr3d(num_var), num_var,
                0166      &        mult_genarr3d(num_var), '(', xx_fname_loc(1:IL), ')'
                0167          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0168      &                       SQUEEZE_RIGHT, myThid )
                0169         ENDIF
                0170        ENDDO
                0171 # endif
                0172
                0173 C     write contributions to costfunction file
                0174
                0175 C--   Each process has calculated the global part for itself.
                0176        IF ( ifc .NE. -1 ) THEN
                0177         WRITE(cfname,'(A,I4.4)') 'costfunction_ctrl.',optimcycle
                0178         OPEN(unit=ifc,file=cfname)
                0179         WRITE(msgBuf,'(A,A)')
                0180      &       'Writing generic ctrl cost function info to ', cfname
                0181         CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0182      &                      SQUEEZE_RIGHT, myThid )
                0183
                0184 # ifdef ALLOW_GENTIM2D_CONTROL
                0185         DO num_var=1,maxCtrlTim2D
                0186          IF (no_gentim2d(num_var).GT.0. _d 0) THEN
                0187           xx_fname_loc = xx_gentim2d_file(num_var)
                0188           IL  = ILNBLNK( xx_fname_loc )
                0189           IL  = max (IL,15)
                0190           WRITE(ifc,'(2A,I2.0,A,1PE22.14,1PE22.14,1X,1PE9.2)')
                0191      &         xx_fname_loc(1:IL), ' (gentim2d ', num_var, ') = ',
                0192      &         f_gentim2d(num_var), no_gentim2d(num_var),
                0193      &         mult_gentim2d(num_var)
                0194          ENDIF
                0195         ENDDO
                0196 # endif
                0197
                0198 # ifdef ALLOW_GENARR2D_CONTROL
                0199         DO num_var=1,maxCtrlArr2D
                0200          IF (no_genarr2d(num_var).GT.0. _d 0) THEN
                0201           xx_fname_loc = xx_genarr2d_file(num_var)
                0202           IL  = ILNBLNK( xx_fname_loc )
                0203           IL  = max (IL,15)
                0204           WRITE(ifc,'(2A,I2.0,A,1PE22.14,1PE22.14,1X,1PE9.2)')
                0205      &         xx_fname_loc(1:IL), ' (genarr2d ', num_var, ') = ',
                0206      &         f_genarr2d(num_var), no_genarr2d(num_var),
                0207      &         mult_genarr2d(num_var)
                0208          ENDIF
                0209         ENDDO
                0210 # endif
                0211
                0212 # ifdef ALLOW_GENARR3D_CONTROL
                0213         DO num_var=1,maxCtrlArr3D
                0214          IF (no_genarr3d(num_var).GT.0. _d 0) THEN
                0215           xx_fname_loc = xx_genarr3d_file(num_var)
                0216           IL  = ILNBLNK( xx_fname_loc )
                0217           IL  = MAX(IL,15)
                0218           WRITE(ifc,'(2A,I2.0,A,1PE22.14,1PE22.14,1X,1PE9.2)')
                0219      &         xx_fname_loc(1:IL), ' (genarr3d ', num_var, ') = ',
                0220      &         f_genarr3d(num_var), no_genarr3d(num_var),
                0221      &         mult_genarr3d(num_var)
                0222          ENDIF
                0223         ENDDO
                0224 # endif
                0225         CLOSE(ifc)
                0226        ENDIF
                0227
                0228 C     useCtrlCostContribution
                0229       ENDIF
                0230
                0231 #endif /* ALLOW_COST */
                0232
                0233       RETURN
                0234       END