pkg/ecco/cost_bp_read.F

8f7d13d0c9 Jean*0001 #include "ECCO_OPTIONS.h"
49b79243e8 Gael*0002
                0003       subroutine cost_bp_read(
f8e779c983 antn*0004      I localobsfile, localstartdate,
49484c0542 Gael*0005      O localobs, localmask,
9f5240b52a Jean*0006      I irec, myThid )
49b79243e8 Gael*0007
                0008 c     ==================================================================
                0009 c     SUBROUTINE cost_bp_read
                0010 c     ==================================================================
                0011 c
                0012 c     o Read a given record of the GRACE data.
                0013 c
                0014 c     started: Gael Forget Oct-2009
                0015 c
                0016 c     ==================================================================
                0017 c     SUBROUTINE cost_bp_read
                0018 c     ==================================================================
                0019
                0020       implicit none
                0021
                0022 c     == global variables ==
                0023
                0024 #include "EEPARAMS.h"
                0025 #include "SIZE.h"
                0026 #include "PARAMS.h"
                0027 #include "GRID.h"
                0028
49484c0542 Gael*0029 #ifdef ALLOW_CAL
                0030 # include "cal.h"
                0031 #endif
                0032 #ifdef ALLOW_ECCO
13d362b8c1 Ou W*0033 # include "ECCO_SIZE.h"
                0034 # include "ECCO.h"
49484c0542 Gael*0035 #endif
49b79243e8 Gael*0036
                0037 c     == routine arguments ==
49484c0542 Gael*0038       character*(MAX_LEN_FNAM) localobsfile
                0039       integer localstartdate(4)
f8e779c983 antn*0040       _RL localobs   (1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
                0041       _RL localmask  (1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
49b79243e8 Gael*0042       integer irec
f8e779c983 antn*0043       integer myThid
49b79243e8 Gael*0044
49484c0542 Gael*0045 #ifdef ALLOW_ECCO
9f5240b52a Jean*0046 c     == external functions ==
                0047       integer  ilnblnk
                0048       external ilnblnk
49b79243e8 Gael*0049
                0050 c     == local variables ==
                0051       integer bi,bj
                0052       integer i,j,k
                0053       integer jmin,jmax
                0054       integer imin,imax
                0055       integer nobs
e5310f7c13 Gael*0056       INTEGER beginlocal, beginmodel, obsrec
49b79243e8 Gael*0057       _RL spval
                0058 cnew(
                0059       integer  il
                0060       integer mody, modm
                0061       integer iyear, imonth
de57a2ec4b Mart*0062       character*(MAX_LEN_FNAM) fnametmp
49b79243e8 Gael*0063       logical exst
                0064 cnew)
                0065
                0066 c     == end of interface ==
                0067
                0068       parameter (spval = -998. )
                0069 ce    --> there is certainly a better place for this.
                0070
                0071       jmin = 1
f8e779c983 antn*0072       jmax = sNy
49b79243e8 Gael*0073       imin = 1
f8e779c983 antn*0074       imax = sNx
e5310f7c13 Gael*0075
49484c0542 Gael*0076        beginlocal = localstartdate(1)/10000
e5310f7c13 Gael*0077        beginmodel = modelstartdate(1)/10000
                0078        obsrec =  ( beginmodel - beginlocal )*nmonthyear
                0079      &         + ( mod(modelstartdate(1)/100,100)
49484c0542 Gael*0080      &            -mod(localstartdate(1)/100,100) )
e5310f7c13 Gael*0081      &         + irec
                0082
49b79243e8 Gael*0083       mody = modelstartdate(1)/10000
                0084       modm = modelstartdate(1)/100 - mody*100
                0085       iyear = mody + INT((modm-1+irec-1)/12)
                0086       imonth = 1 + MOD(modm-1+irec-1,12)
                0087
49484c0542 Gael*0088       il=ilnblnk(localobsfile)
de57a2ec4b Mart*0089       write(fnametmp,'(2a,i4)')
49484c0542 Gael*0090      &     localobsfile(1:il), '_', iyear
49b79243e8 Gael*0091       inquire( file=fnametmp, exist=exst )
                0092       if (.NOT. exst) then
de57a2ec4b Mart*0093          write(fnametmp,'(a)') localobsfile(1:il)
e5310f7c13 Gael*0094          imonth = obsrec
49b79243e8 Gael*0095       endif
                0096
e5310f7c13 Gael*0097       if ( (obsrec.GT.0).AND.(imonth.GT.0) ) then
f8e779c983 antn*0098        CALL READ_REC_3D_RL( fnametmp, cost_iprec, 1,
                0099      &                      localobs, imonth, 0, myThid )
e5310f7c13 Gael*0100       else
9f5240b52a Jean*0101         do bj = myByLo(myThid), myByHi(myThid)
                0102          do bi = myBxLo(myThid), myBxHi(myThid)
e5310f7c13 Gael*0103           do j = jmin,jmax
                0104            do i = imin,imax
49484c0542 Gael*0105             localobs(i,j,bi,bj) = spval
e5310f7c13 Gael*0106            enddo
                0107           enddo
                0108          enddo
                0109         enddo
                0110       endif
49b79243e8 Gael*0111
                0112       nobs = 0
                0113
9f5240b52a Jean*0114       do bj = myByLo(myThid), myByHi(myThid)
                0115         do bi = myBxLo(myThid), myBxHi(myThid)
49b79243e8 Gael*0116           k = 1
                0117           do j = jmin,jmax
                0118             do i = imin,imax
a01563ca86 Gael*0119 c              if (maskC(i,j,k,bi,bj) .eq. 0.) then
49484c0542 Gael*0120 c                localmask(i,j,bi,bj) = 0. _d 0
a01563ca86 Gael*0121 c              else
49484c0542 Gael*0122 c                localmask(i,j,bi,bj) = 1. _d 0
a01563ca86 Gael*0123 c              endif
49484c0542 Gael*0124               if (localobs(i,j,bi,bj) .le. spval) then
                0125                 localmask(i,j,bi,bj) = 0. _d 0
49b79243e8 Gael*0126               else
49484c0542 Gael*0127                 localmask(i,j,bi,bj) = 1. _d 0
49b79243e8 Gael*0128               endif
49484c0542 Gael*0129               localobs(i,j,bi,bj) = localobs(i,j,bi,bj)*
                0130      &                              localmask(i,j,bi,bj)
                0131               nobs = nobs + int(localmask(i,j,bi,bj))
49b79243e8 Gael*0132             enddo
                0133           enddo
                0134         enddo
                0135       enddo
                0136
                0137 #endif
                0138
f8e779c983 antn*0139       RETURN
                0140       END