pkg/cost/cost_copy_file.F

69361556c2 Mart*0001 #include "COST_OPTIONS.h"
                0002
                0003 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0004 CBOP
                0005 C !ROUTINE: COST_COPY_FILE
                0006
                0007 C !INTERFACE:
                0008       SUBROUTINE COST_COPY_FILE( oUnit, optimcycle, myThid )
                0009 C !DESCRIPTION:
                0010 C     Helper routine to hide irreducible statements from TAF:
                0011 C     Copy content of costfunction_${pkg}.XXXX to oUnit
                0012
                0013 C     !USES:
                0014       IMPLICIT NONE
                0015 C     == Global variables ===
                0016 #include "EEPARAMS.h"
                0017
                0018 C !INPUT/OUTPUT PARAMETERS:
                0019 C     oUnit  :: file unit of output file (set in cost_final.F)
                0020 C     optimcycle :: cycle number of the off-line optimization.
                0021 C     myThid :: my Thread Id number
                0022       INTEGER oUnit
                0023       INTEGER optimcycle
                0024       INTEGER myThid
                0025 CEOP
                0026
                0027 C !FUNCTIONS:
                0028       INTEGER  ILNBLNK
                0029       EXTERNAL ILNBLNK
                0030
                0031 C !LOCAL VARIABLES:
                0032       INTEGER iUnit
                0033       INTEGER IL
                0034       INTEGER nPkg, iPkg
                0035       PARAMETER ( nPkg = 7 )
                0036       CHARACTER*8 pkgNames(nPkg)
                0037       CHARACTER*(MAX_LEN_FNAM) cfname
                0038       CHARACTER*(MAX_LEN_PREC) RECORD
                0039       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0040       LOGICAL cfexist
                0041
                0042 C     This list can be appened as necessary with the only limitation
                0043 C     that the character variables need to be all of the same length.
                0044       DATA pkgNames /
                0045      &     'profiles',
                0046      &     'obsfit  ',
                0047      &     'ecco    ',
                0048      &     'ctrl    ',
                0049      &     'obcs    ',
                0050      &     'seaice  ',
                0051      &     'shelfice' /
                0052
                0053       iUnit = scrUnit1
                0054       DO ipkg = 1, nPkg
                0055        cfexist = .FALSE.
                0056        IL = ILNBLNK( pkgNames(ipkg) )
                0057        WRITE(cfname,'(3A,I4.4)')
                0058      &      'costfunction_',pkgNames(ipkg)(1:IL),'.',optimcycle
                0059        IL = ILNBLNK( cfname )
                0060        INQUIRE(FILE=cfname(1:IL), EXIST=cfexist)
                0061        IF ( cfexist ) THEN
                0062         WRITE(msgBuf,'(A,A)')
                0063      &       'Reading cost function info from ', cfname(1:IL)
                0064         CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0065      &                      SQUEEZE_RIGHT, myThid )
                0066         OPEN(UNIT=iUnit,FILE=cfname(1:IL),
                0067      &       _READONLY_ACTION STATUS='OLD')
                0068
                0069         DO WHILE ( .TRUE. )
                0070          READ( iUnit, FMT='(A)', END=1001 ) RECORD
                0071          IL = MAX(ILNBLNK( RECORD ),1)
                0072          WRITE( oUnit, FMT='(A)') RECORD(1:IL)
                0073         ENDDO
                0074  1001   CONTINUE
                0075
                0076         CLOSE(iUnit)
                0077        ENDIF
                0078       ENDDO
                0079
                0080       RETURN
                0081       END