/[MITgcm]/MITgcm/pkg/fizhi/update_ocean_exports.F
ViewVC logotype

Diff of /MITgcm/pkg/fizhi/update_ocean_exports.F

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph | View Patch Patch

revision 1.3 by molod, Tue Jun 8 16:42:54 2004 UTC revision 1.18 by molod, Tue Mar 8 19:48:51 2005 UTC
# Line 1  Line 1 
1  C $Header$  C $Header$
2  C $Name$  C $Name$
3    
4    #include "FIZHI_OPTIONS.h"
5         subroutine update_ocean_exports (myTime, myIter, myThid)         subroutine update_ocean_exports (myTime, myIter, myThid)
6  c----------------------------------------------------------------------  c----------------------------------------------------------------------
7  c  Subroutine update_ocean_exports - 'Wrapper' routine to update  c  Subroutine update_ocean_exports - 'Wrapper' routine to update
# Line 11  c Call:  getsst  (Return the current sst Line 12  c Call:  getsst  (Return the current sst
12  c        getsice (Return the current sea ice field-read data if needed)  c        getsice (Return the current sea ice field-read data if needed)
13  c-----------------------------------------------------------------------  c-----------------------------------------------------------------------
14         implicit none         implicit none
 #include "CPP_OPTIONS.h"  
15  #include "SIZE.h"  #include "SIZE.h"
16  #include "GRID.h"  #include "GRID.h"
17  #include "fizhi_ocean_coms.h"  #include "fizhi_ocean_coms.h"
18  #include "EEPARAMS.h"  #include "EEPARAMS.h"
19  #include "chronos.h"  #include "chronos.h"
20    
21         integer myTime, myIter, myThid         integer myIter, myThid
22           _RL myTime
23    
24         integer i, j, L, bi, bj         integer i, j, bi, bj, biglobal, bjglobal
25         integer im1, im2, jm1, jm2, idim1, idim2, jdim1, jdim2         integer im1, im2, jm1, jm2, idim1, idim2, jdim1, jdim2
26           integer nSxglobal, nSyglobal
        im1 = 1-OLx  
        im2 = sNx+OLx  
        jm1 = 1-OLy  
        jm2 = sNy+OLy  
        idim1 = 1  
        idim2 = sNx  
        jdim1 = 1  
        jdim2 = sNy  
   
27         integer ksst,kice         integer ksst,kice
28           _RL        sstmin
 c Declare Local Variables  
 c -----------------------  
        real        sstmin  
29         parameter ( sstmin = 273.16 )         parameter ( sstmin = 273.16 )
30    
31         integer i,j,im,jm         idim1 = 1-OLx
32           idim2 = sNx+OLx
33           jdim1 = 1-OLy
34           jdim2 = sNy+OLy
35           im1 = 1
36           im2 = sNx
37           jm1 = 1
38           jm2 = sNy
39           nSxglobal = nSx*nPx
40           nSyglobal = nSy*nPy
41    
42  C*********************************************************************         call mdsfindunit( ksst, myThid )
43  C****             Interpolate Data to Current Time                ****         call mdsfindunit( kice, myThid )
44  C*********************************************************************  
45    C***********************************************************************
46    
47         call getsst (ksst,nymd,nhms,sst,im,jm)         DO BJ = myByLo(myThid),myByHi(myThid)
48         call getsice (kice,nymd,nhms,sice,im,jm)         DO BI = myBxLo(myThid),myBxHi(myThid)
49    
50           biglobal=bi+(myXGlobalLo-1)/im2
51           bjglobal=bj+(myYGlobalLo-1)/jm2
52    
53           call getsst(ksst,idim1,idim2,jdim1,jdim2,im1,im2,jm1,jm2,nSx,
54         .  nSy,nSxglobal,nSyglobal,bi,bj,biglobal,bjglobal,nymd,nhms,sst)
55           call getsice(kice,idim1,idim2,jdim1,jdim2,im1,im2,jm1,jm2,nSx,
56         .  nSy,nSxglobal,nSyglobal,bi,bj,biglobal,bjglobal,nymd,nhms,sice)
57    
58  c Check for Minimum Open-Water SST  c Check for Minimum Open-Water SST
59  c --------------------------------  c --------------------------------
60         do j=1,jm         do j=jm1,jm2
61         do i=1,im         do i=im1,im2
62         if(sice(i,j).eq.0.0 .and. sst(i,j).lt.sstmin)sst(i,j) = sstmin         if(sice(i,j,bi,bj).eq.0.0 .and. sst(i,j,bi,bj).lt.sstmin)
63         .                                          sst(i,j,bi,bj) = sstmin
64         enddo         enddo
65         enddo         enddo
66    
67           ENDDO
68           ENDDO
69    
70         return         return
71         end         end
72    
73         subroutine getsice ( iunit,nymd,nhms,sice,im,jm )         subroutine getsice(iunit,idim1,idim2,jdim1,jdim2,im1,im2,jm1,jm2,
74  C************************************************************************       .     nSumx,nSumy,nPgx,nPgy,bi,bj,biglobal,bjglobal,nymd,nhms,sice)
 C!GETSICE  
75  C************************************************************************  C************************************************************************
76  C  C
77  C!ROUTINE:      GETSICE  C!ROUTINE:      GETSICE
 C!PROGRAMMER:   Sharon Nebuda  
 C!DATE CODED:   May 8, 1996  
78  C!DESCRIPTION:  GETSICE returns the sea ice depth.  C!DESCRIPTION:  GETSICE returns the sea ice depth.
79  C!              This routine is adaptable for any frequency  C!              This routine is adaptable for any frequency
80  C!              data upto a daily frequency.    C!              data upto a daily frequency.  
81  C!              note: for diurnal data ndmax should be increased.  C!              note: for diurnal data ndmax should be increased.
82  C  C
83  C!INPUT PARAMETERS:  C!INPUT PARAMETERS:
84  C!              iunit   Unit number assigned to the sice data file  C!      iunit     Unit number assigned to the sice data file
85  C!              nymd    YYMMDD of the current model timestep  C!      idim1     Start dimension in x-direction
86  C!              nhms    HHMMSS of the model time  C!      idim2     End dimension in x-direction
87  C!            im     Number of x points  C!      jdim1     Start dimension in y-direction
88  C!            jm     Number of y points  C!      jdim2     End dimension in y-direction
89  C!       lattice     Grid Decomposition defined by Dynamics  C!      im1       Begin of x-direction span for filling sice
90    C!      im2       End of x-direction span for filling sice
91    C!      jm1       Begin of y-direction span for filling sice
92    C!      jm2       End of y-direction span for filling sice
93    C!      nSumx     Number of processors in x-direction (local processor)
94    C!      nSumy     Number of processors in y-direction (local processor)
95    C!      nPgx      Number of processors in x-direction (global)
96    C!      nPgx      Number of processors in y-direction (global)
97    C!      bi        Processor number in x-direction (local to processor)
98    C!      bj        Processor number in y-direction (local to processor)
99    C!      biglobal  Processor number in x-direction (global)
100    C!      bjglobal  Processor number in y-direction (global)
101    C!      nymd      YYMMDD of the current model timestep
102    C!      nhms      HHMMSS of the model time
103  C  C
104  C!OUTPUT PARAMETERS:  C!OUTPUT PARAMETERS:
105  C!              sice(im,jm)     Sea ice depth in meters  C!      sice(idim1:idim2,jdim1:jdim2,nSumx,nSumy) Sea ice depth in meters
106  C  C
107  C!ROUTINES CALLED:  C!ROUTINES CALLED:
108  C  C
109  C!      bcdata          Reads the data for a given unit number  C!      bcdata       Reads the data for a given unit number
110  C!      bcheader        Reads the header info for a given unit number  C!      bcheader     Reads the header info for a given unit number
111  C!     interp_time   Returns weights for linear interpolation  C!      interp_time  Returns weights for linear interpolation
112  C  C
113  C--------------------------------------------------------------------------  C--------------------------------------------------------------------------
114    
       use dynamics_lattice_module  
115        implicit none        implicit none
116        type ( dynamics_lattice_type ) lattice  #include "SIZE.h"
117    
118          integer iunit,idim1,idim2,jdim1,jdim2,im1,im2,jm1,jm2,nSumx,nSumy
119          integer nPgx,nPgy,bi,bj,biglobal,bjglobal,nymd,nhms
120    
121  c MPI Utilities        _RL sice(idim1:idim2,jdim1:jdim2,nSumx,nSumy)
 c -------------  
       include 'mpif.h'  
       integer  ierror  
122    
123  C  Parameter statements  C Maximum number of dates in one year for the data
124        integer   ndmax   ! Maximum number of dates in one year for the data        integer   ndmax
125        parameter (ndmax = 370)        parameter (ndmax = 370)
126    
127  C  Variables passed to the routine:        character*8  cname
128        integer   iunit   ! Unit number assigned to the sea ice data file        character*80 cdscrip
129        integer   nymd    ! YYMMDD of the current model timestep        character*40 sicedata
130        integer   nhms    ! HHMMSS of the model time        _RL fac1, fac2, lat0, lon0, timebc1, timebc2, timemod, undef
131        integer        im     ! Number of x points        logical first, found, error
132        integer        jm     ! Number of y points        integer i,j,n,nn,iyear,iyearbc,nd,ndby3,imbc,jmbc,npxbc,npybc
133          integer ndatebc,nhmsbc(ndmax), nhmsbc1, nhmsbc2,nrec
134  C  Variables returned by the routine:        integer nymdbc(ndmax),nymdbc1,nymdbc2,nymdmod
135        real      sice(im,jm)     ! Sea ice depth in meters  
136          _RL sicebc1(sNx,sNy,nSx*nPx,nSy*nPy)
137  C  Variables unique to the routine:        _RL sicebc2(sNx,sNy,nSx*nPx,nSy*nPy)
       character*8  cname        ! Name of the data in the file header  
       character*80 cdscrip      ! Description of the data in the file header  
       real      fac1            ! Weighted value (fraction) of the data  
                                 ! before the model time  
       real      fac2            ! Weighted value (fraction) of the data  
                                 ! after the model time  
       logical   first           ! True for first time using the dates for the  
                                 ! BC data file.  Then read in the header file.  
       logical   found           ! If false, then the data surrounding the model  
                                 ! time was not found  
       logical   error           ! TRUE if problem with data  
       integer   i,j,n,nn        ! DO loop counters  
       integer   iyear           ! Year of model  
       integer   iyearbc         ! Year of boundary condition data  
       real      lat0            ! Starting lat of the bc data set (future use)  
       real      lon0            ! Starting lon of the bc data set (future use)  
       integer   nd              ! Counter for record number of data to read  
       integer   ndby3           ! int(ndatebc/3) used for write statement  
       integer   imbc            ! IM read from the BC data  
       integer   jmbc            ! JM read from the BC data  
       integer   ndatebc         ! Number of dates in the BC file  
       integer   nhmsbc(ndmax)   ! HHMMSS of the data time (not needed currently)  
       integer   nhmsbc1 ! HHMMSS of the earlier data kept from last timestep  
       integer   nhmsbc2 ! HHMMSS of the later data kept from last timestep  
       integer   nrec            ! Record number of the header (set to 1)  
       integer   nymdbc(ndmax)   ! YYYYMMDD of each data  
       integer   nymdbc1 ! YYYYMMDD of the earlier data kept from last timestep  
       integer   nymdbc2 ! YYYYMMDD of the later data kept from last timestep  
       integer   nymdmod         ! YYYYMMDD of the current model timestep  
       real      timebc1         ! YYYYMMDD.HHMMSS of the earlier bc data  
       real      timebc2         ! YYYYMMDD.HHMMSS of the later bc data  
       real      timemod         ! YYYYMMDD.HHMMSS of the current timestep  
       real      undef           ! Undefined value for missing data  
   
 C Define Allocatable Arrays  
       real, allocatable, save :: sicebc1(:,:)    ! Sea ice 0=no 1=yes from the bc data  
                                                  ! of the date before the model time  
       real, allocatable, save :: sicebc2(:,:)    ! Sea ice 0=no 1=yes from bc data  
                                                  ! of the date after the model time  
138    
139  C--------- Variable Initialization ---------------------------------  C--------- Variable Initialization ---------------------------------
140    
# Line 161  C--------- Variable Initialization ----- Line 142  C--------- Variable Initialization -----
142        data error /.false./        data error /.false./
143    
144  c  save header info  c  save header info
145        save imbc, jmbc, lat0, lon0, ndatebc, undef, nymdbc, nhmsbc        save imbc,jmbc,npxbc,npybc,lat0,lon0,ndatebc,undef,nymdbc,nhmsbc
146        save nymdbc1, nymdbc2, nhmsbc1, nhmsbc2        save nymdbc1, nymdbc2, nhmsbc1, nhmsbc2
147        save first        save first
148          save sicebc1, sicebc2
149    
150  c  this only works for between 1950-2050  c  this only works for between 1950-2050
151        if (nymd .lt. 500101) then        if (nymd .lt. 500101) then
# Line 174  c  this only works for between 1950-2050 Line 156  c  this only works for between 1950-2050
156          nymdmod = nymd          nymdmod = nymd
157        endif        endif
158    
159          sicedata='sice19232.weekly.clim'
160    
161  c  initialize so that first time through they have values for the check  c  initialize so that first time through they have values for the check
162  c  these vaules make the iyear .ne. iyearbc true anyways for  c  these vaules make the iyear .ne. iyearbc true anyways for
163  c  for the first time so first isnt checked below.  c  for the first time so first isnt checked below.
164    
165        if (first) then        if (first) then
       allocate ( sicebc1(lattice%imglobal,lattice%jmglobal) )    ! Allocate Memory for sicebc1  
       allocate ( sicebc2(lattice%imglobal,lattice%jmglobal) )    ! Allocate Memory for sicebc2  
166          nymdbc(2) = 0          nymdbc(2) = 0
167          nymdbc1   = 0          nymdbc1   = 0
168          nymdbc2   = 0          nymdbc2   = 0
# Line 195  C---------- Read in Header file -------- Line 177  C---------- Read in Header file --------
177        iyearbc = nymdbc(2)/10000        iyearbc = nymdbc(2)/10000
178    
179        if( iyear.ne.iyearbc ) then        if( iyear.ne.iyearbc ) then
         if( lattice%myid.eq.0 ) then  
180    
181          close(iunit)         close(iunit)
182          open (iunit, form='unformatted', access='direct',recl=lattice%imglobal*lattice%jmglobal*4)         open (iunit,file=sicedata,form='unformatted',access='direct',
183          nrec = 1       .                                         recl=im2*jm2*nPgx*nPgy*4)
184          call bcheader (iunit, ndmax, nrec,         nrec = 1
185       .                 cname, cdscrip, imbc, jmbc, lat0, lon0,         call bcheader (iunit, ndmax, nrec,
186       .                 ndatebc, nymdbc, nhmsbc, undef, error)       .          cname, cdscrip, imbc, jmbc, npxbc, npybc, lat0, lon0,
187         .          ndatebc, nymdbc, nhmsbc, undef, error)
188    
189  C--------- Check data for Compatibility ------------------------------  C--------- Check data for Compatibility ------------------------------
190    
191  C Check for correct data in boundary condition file  C Check for correct data in boundary condition file
192         if (.not.error .and. cname.ne.'SICE') then         if (.not.error .and. cname.ne.'SICE') then
193              write(6,*) 'Wrong data in SICE boundary condition file => ',cname          write(6,*)'Wrong data in SICE boundary condition file => ',cname
194              error = .true.          error = .true.
195         endif         endif
196    
197  C Check Horizontal Resolution  C Check Horizontal Resolution
198         if (.not.error .and. imbc*jmbc.ne.lattice%imglobal*lattice%jmglobal) then         if(.not.error.and.imbc*jmbc*npxbc*npybc.ne.im2*jm2*npgx*npgy)then
199              write(6,*) 'Boundary Condition Resolution DOES NOT match Model Resolution!'          write(6,*) ' B.C. Resolution DOES NOT match Model Resolution!'
200              write(6,*) 'Boundary Condition Resolution:  ',imbc*jmbc          write(6,*) ' B.C. Resolution:  ',imbc*jmbc*npxbc*npybc
201              write(6,*) '             Model Resolution:  ',lattice%imglobal*lattice%jmglobal          write(6,*) 'Model Resolution:  ',im2*jm2*npgx*npgy
202              error = .true.          error = .true.
203         endif         endif
204    
205  C Check Year  C Check Year
206         iyearbc = nymdbc(2)/10000         iyearbc = nymdbc(2)/10000
207         if (.not.error .and. iyear.ne.iyearbc .and. iyearbc.ne.0) then         if (.not.error .and. iyear.ne.iyearbc .and. iyearbc.ne.0) then
208              write(6,*) 'Boundary Condition Year DOES NOT match REQUESTED Year!'          write(6,*)'     B.C. Year DOES NOT match REQUESTED Year!'
209              write(6,*) 'Boundary Condition Year:  ', iyearbc          write(6,*)'     B.C. Year:  ', iyearbc
210              write(6,*) '         Requested Year:  ', iyear          write(6,*)'Requested Year:  ', iyear
211              error = .true.          error = .true.
212         endif         endif
213    
214         if (.not.error)   then                   if (.not.error)   then
215  C if climatology, fill dates for data with current model year  C if climatology, fill dates for data with current model year
216              if (iyearbc.eq.0) then                        if (iyearbc.eq.0) then          
217              write(6,*)           write(6,*)
218              write(6,*) 'Climatological Dataset is being used.'             write(6,*) 'Climatological Dataset is being used.'  
219              write(6,*) 'Current model year will be used to fill Header Dates'           write(6,*) 'Current model year to be used to fill Header Dates'
220                do n = 2, ndatebc-1           do n = 2, ndatebc-1
221                 nymdbc(n) = nymdbc(n) +(nymdmod/10000)*10000            nymdbc(n) = nymdbc(n) +(nymdmod/10000)*10000
222                enddo           enddo
223  C  For the first date subtract 1 year from the current model NYMD  C  For the first date subtract 1 year from the current model NYMD
224                n = 1           n = 1
225                nymdbc(n) = nymdbc(n) +(nymdmod/10000-1)*10000           nymdbc(n) = nymdbc(n) +(nymdmod/10000-1)*10000
226  C  For the last date add 1 year to the current model NYMD  C  For the last date add 1 year to the current model NYMD
227                n = ndatebc           n = ndatebc
228                nymdbc(n) = nymdbc(n) +(nymdmod/10000+1)*10000           nymdbc(n) = nymdbc(n) +(nymdmod/10000+1)*10000
229              endif          endif
230    
231  C  Write out header info  C  Write out header info
232         write(6,*) ' Updated boundary condition data'          write(6,*) ' Updated boundary condition data'
233         write(6,*) ' ---------------------------------'          write(6,*) ' ---------------------------------'
234         write(6,*) ' Variable: ',cname          write(6,*) ' Variable: ',cname
235         write(6,*) ' Description: ',cdscrip          write(6,*) ' Description: ',cdscrip
236         write(6,*) ' Resolution: x= ',imbc,' y= ',jmbc,' Undefined value = ',undef          write(6,*) ' Resolution: x= ',imbc,' y= ',jmbc,
237         write(6,*) ' Starting latitude = ',lat0,' longitude =',lon0       .                                       ' Undefined value = ',undef
238         write(6,*) ' Data valid at these times: '          write(6,*) ' Starting latitude = ',lat0,' longitude =',lon0
239         ndby3 = ndatebc/3          write(6,*) ' Data valid at these times: '
240         do n = 1, ndby3*3,3          ndby3 = ndatebc/3
241          write(6,1000) (nn,nymdbc(nn),nhmsbc(nn),nn=n,n+2)          do n = 1, ndby3*3,3
242   1000   format(3(2x,i3,':',i8,2x,i8))           write(6,1000) (nn,nymdbc(nn),nhmsbc(nn),nn=n,n+2)
243         enddo   1000    format(3(2x,i3,':',i8,2x,i8))
244         write(6,1000) (nn,nymdbc(nn),nhmsbc(nn),nn=ndby3*3+1,ndatebc)          enddo
245        endif  ! End error  Check          write(6,1000) (nn,nymdbc(nn),nhmsbc(nn),nn=ndby3*3+1,ndatebc)
246           endif  
       endif  ! End MYID=0 Check  
   
 c Broadcast information to other PEs  
 c ----------------------------------  
 #if (mpi)  
        call mpi_bcast ( error,1,mpi_logical,0,lattice%comm,ierror )  
 #endif  
        if( error ) call my_exit (101)  
   
 #if (mpi)  
        call mpi_bcast ( ndatebc,1     ,mpi_integer,0,lattice%comm,ierror )  
        call mpi_bcast ( nymdbc,ndatebc,mpi_integer,0,lattice%comm,ierror )  
        call mpi_bcast ( nhmsbc,ndatebc,mpi_integer,0,lattice%comm,ierror )  
 #endif  
247    
248        endif  ! New Year Info Check        endif
249    
250  C---------- Read sice data if necessary -------------------------------  C---------- Read sice data if necessary -------------------------------
251    
252          found = .false.        found = .false.
253          nd = 2        nd = 2
254    
255  c  If model time is not within the times of saved sice data  c  If model time is not within the times of saved sice data
256  c  from previous call to getsice then read new data  c  from previous call to getsice then read new data
257    
258          timemod = float(nymdmod) + float(nhms)   /1000000        timemod = float(nymdmod) + float(nhms)   /1000000
259          timebc1 = float(nymdbc1) + float(nhmsbc1)/1000000        timebc1 = float(nymdbc1) + float(nhmsbc1)/1000000
260          timebc2 = float(nymdbc2) + float(nhmsbc2)/1000000        timebc2 = float(nymdbc2) + float(nhmsbc2)/1000000
261          if (timemod .lt. timebc1 .or. timemod .ge. timebc2) then  
262          if (timemod .lt. timebc1 .or. timemod .ge. timebc2) then
263          do while (.not.found .and. nd .le. ndatebc)  
264            timebc2 = float(nymdbc(nd)) + float(nhmsbc(nd))/1000000         do while (.not.found .and. nd .le. ndatebc)
265            if (timebc2 .gt. timemod) then                  timebc2 = float(nymdbc(nd)) + float(nhmsbc(nd))/1000000
266              nymdbc1 = nymdbc(nd-1)          if (timebc2 .gt. timemod) then  
267              nymdbc2 = nymdbc(nd)           nymdbc1 = nymdbc(nd-1)
268              nhmsbc1 = nhmsbc(nd-1)           nymdbc2 = nymdbc(nd)
269              nhmsbc2 = nhmsbc(nd)           nhmsbc1 = nhmsbc(nd-1)
270              if ( lattice%myid.eq.0 ) call bcdata (iunit, imbc, jmbc, nd, nd+1, sicebc1, sicebc2)           nhmsbc2 = nhmsbc(nd)
271  #if (mpi)           call bcdata (iunit,imbc,jmbc,nPgx,nPgy,nd,nd+1,sicebc1,sicebc2)
272              call mpi_bcast ( sicebc1,lattice%imglobal*lattice%jmglobal,mpi_double_precision,0,lattice%comm,ierror )           found = .true.
273              call mpi_bcast ( sicebc2,lattice%imglobal*lattice%jmglobal,mpi_double_precision,0,lattice%comm,ierror )          else
274  #endif           nd = nd + 1
275              found = .true.          endif
276            else         enddo
             nd = nd + 1  
           endif  
         enddo  
277    
278  c  Otherwise the data from the last time in getsice surrounds the  c  Otherwise the data from the last time in getsice surrounds the
279  c  current model time.  c  current model time.
280    
281          else        else
282            found = .true.         found = .true.
283          endif        endif
284    
285            if (.not.found) then        if (.not.found) then
286              if( lattice%myid.eq.0 ) print *, 'STOP: Could not find SICE boundary condition dates surrounding the model time.'         print *, 'STOP: Could not find SICE dates for model time.'
287              call my_finalize         call my_finalize
288              call my_exit (101)         call my_exit (101)
289            endif        endif
290    
291  C---------- Interpolate sice data ------------------------------------  C---------- Interpolate sice data ------------------------------------
292    
293            call interp_time ( nymdmod,nhms, nymdbc1,nhmsbc1, nymdbc2,nhmsbc2, fac1,fac2 )        call interp_time(nymdmod,nhms,nymdbc1,nhmsbc1,nymdbc2,nhmsbc2,
294         .                                                       fac1,fac2)
295    
296            do j = 1, jm        do j = jm1,jm2
297            do i = 1, im        do i = im1,im2
298              sice(i,j) = sicebc1( lattice%iglobal(i),lattice%jglobal(j) )*fac1         sice(i,j,bi,bj) = sicebc1(i,j,biglobal,bjglobal)*fac1
299       .                + sicebc2( lattice%iglobal(i),lattice%jglobal(j) )*fac2       .                 + sicebc2(i,j,biglobal,bjglobal)*fac2
300  c average to 0 or 1  c average to 0 or 1
301  c -----------------  c -----------------
302              if (sice(i,j) .ge. 0.5) then         if (sice(i,j,bi,bj) .ge. 0.5) then
303                  sice(i,j) = 1.          sice(i,j,bi,bj) = 1.
304              else         else
305                  sice(i,j) = 0.          sice(i,j,bi,bj) = 0.
306              endif         endif
307            enddo        enddo
308            enddo        enddo
309    
310  C---------- Fill sice with depth of ice ------------------------------------  C---------- Fill sice with depth of ice ------------------------------------
311          do j = jm1,jm2
312            do j = 1, jm        do i = im1,im2
313            do i = 1, im         if (sice(i,j,bi,bj) .eq. 1.) then                
314              if (sice(i,j) .eq. 1.) then         ! sea ice present          sice(i,j,bi,bj) = 3.
315                  sice(i,j) = 3.         endif
316              endif        enddo
317            enddo        enddo
           enddo  
   
318  C---------------------------------------------------------------------------  C---------------------------------------------------------------------------
319    
320        return        return
321        end        end
322        subroutine getsst ( iunit,nymd,nhms,sst,im,jm,lattice )        subroutine getsst(iunit,idim1,idim2,jdim1,jdim2,im1,im2,jm1,jm2,
323  C************************************************************************       .      nSumx,nSumy,nPgx,nPgy,bi,bj,biglobal,bjglobal,nymd,nhms,sst)
 C!GETSST  
324  C************************************************************************  C************************************************************************
325  C  C
326  C!ROUTINE:      GETSST  C!ROUTINE:      GETSST
 C!PROGRAMMER:   Sharon Nebuda  
 C!DATE CODED:   May 8, 1996  
327  C!DESCRIPTION:  GETSST gets the SST data.  C!DESCRIPTION:  GETSST gets the SST data.
328  C!              This routine is adaptable for any frequency  C!              This routine is adaptable for any frequency
329  C!              data upto a daily frequency.    C!              data upto a daily frequency.  
330  C!              note: for diurnal data ndmax should be increased.  C!              note: for diurnal data ndmax should be increased.
331  C  C
332  C!INPUT PARAMETERS:  C!INPUT PARAMETERS:
333  C!              iunit   Unit number assigned to the sst data file  C!      iunit     Unit number assigned to the sice data file
334  C!              nymd    YYMMDD of the current model timestep  C!      idim1     Start dimension in x-direction
335  C!              nhms    HHMMSS of the model time  C!      idim2     End dimension in x-direction
336  C!            im     Number of x points  C!      jdim1     Start dimension in y-direction
337  C!            jm     Number of y points  C!      jdim2     End dimension in y-direction
338  C!       lattice     Grid Decomposition defined by Dynamics  C!      im1       Begin of x-direction span for filling sice
339    C!      im2       End of x-direction span for filling sice
340    C!      jm1       Begin of y-direction span for filling sice
341    C!      jm2       End of y-direction span for filling sice
342    C!      nSumx     Number of processors in x-direction (local processor)
343    C!      nSumy     Number of processors in y-direction (local processor)
344    C!      nPgx      Number of processors in x-direction (global)
345    C!      nPgy      Number of processors in y-direction (global)
346    C!      bi        Processor number in x-direction (local to processor)
347    C!      bj        Processor number in y-direction (local to processor)
348    C!      biglobal  Processor number in x-direction (global)
349    C!      bjglobal  Processor number in y-direction (global)
350    C!      nymd      YYMMDD of the current model timestep
351    C!      nhms      HHMMSS of the model time
352  C  C
353  C!OUTPUT PARAMETERS:  C!OUTPUT PARAMETERS:
354  C!              sst(im,jm)      Sea surface temperature in Kelvin  C!      sst(idim1:idim2,jdim1:jdim2,nSumx,nSumy) Sea surface temperature (K)
355  C  C
356  C!ROUTINES CALLED:  C!ROUTINES CALLED:
357  C  C
# Line 387  C!     interp_time   Returns weights for Line 361  C!     interp_time   Returns weights for
361  C  C
362  C--------------------------------------------------------------------------  C--------------------------------------------------------------------------
363    
       use dynamics_lattice_module  
364        implicit none        implicit none
365        type ( dynamics_lattice_type ) lattice  #include "SIZE.h"
366    
367  c MPI Utilities        integer iunit,idim1,idim2,jdim1,jdim2,im1,im2,jm1,jm2,nSumx,nSumy
368  c -------------        integer nPgx,nPgy,bi,bj,biglobal,bjglobal,nymd,nhms
       include 'mpif.h'  
       integer  ierror  
369    
370  C  Parameter statements        _RL sst(idim1:idim2,jdim1:jdim2,nSumx,nSumy)
371        integer   ndmax   ! Maximum number of dates in one year for the data  
372    C Maximum number of dates in one year for the data
373          integer   ndmax
374        parameter (ndmax = 370)        parameter (ndmax = 370)
375    
376  C  Variables passed to the routine:        character*8  cname
377        integer   iunit   ! Unit number assigned to the SST data file        character*80 cdscrip
378        integer   nymd    ! YYMMDD of the current model timestep        character*20 sstdata
379        integer   nhms    ! HHMMSS of the model time        _RL fac1, fac2, lat0, lon0, timebc1, timebc2, timemod, undef
380        integer        im     ! Number of x points        logical first, found, error
381        integer        jm     ! Number of y points        integer i,j,n,nn,iyear,iyearbc,nd,ndby3,imbc,jmbc,npxbc,npybc
382          integer ndatebc,nhmsbc(ndmax), nhmsbc1, nhmsbc2,nrec
383  C  Variables returned by the routine:        integer nymdbc(ndmax),nymdbc1,nymdbc2,nymdmod
384        real      sst(im,jm)      ! Sea surface temperature in Kelvin  
385          _RL sstbc1(sNx,sNy,nSx*nPx,nSy*nPy)
386  C  Variables unique to the routine:        _RL sstbc2(sNx,sNy,nSx*nPx,nSy*nPy)
       character*8  cname        ! Name of the data in the file header  
       character*80 cdscrip      ! Description of the data in the file header  
       real      fac1            ! Weighted value (fraction) of the data  
                                 ! before the model time  
       real      fac2            ! Weighted value (fraction) of the data  
                                 ! after the model time  
       logical   first           ! True for first time using the dates for the  
                                 ! BC data file.  Then read in the header file.  
       logical   found           ! If false, then the data surrounding the model  
                                 ! time was not found  
       logical error         ! TRUE if problem with data  
       integer   i,j,n,nn        ! DO loop counters  
       integer   iyear           ! Year of model  
       integer   iyearbc         ! Year of boundary condition data  
       real      lat0            ! Starting lat of the bc data set (future use)  
       real      lon0            ! Starting lon of the bc data set (future use)  
       integer   nd              ! Counter for record number of data to read  
       integer   ndby3           ! int(ndatebc/3) used for write statement  
       integer   imbc            ! IM read from the BC data  
       integer   jmbc            ! JM read from the BC data  
       integer   ndatebc         ! Number of dates in the BC file  
       integer   nhmsbc(ndmax)          ! HHMMSS of the data time (not needed currently)  
       integer   nhmsbc1         ! HHMMSS of the earlier data kept from last timestep  
       integer   nhmsbc2                ! HHMMSS of the later data kept from last timestep  
       integer nrec                    ! Record number of the header (set to 1)  
       integer   nymdbc(ndmax)          ! YYYYMMDD of each data  
       integer   nymdbc1         ! YYYYMMDD of the earlier data kept from last timestep  
       integer   nymdbc2                ! YYYYMMDD of the later data kept from last timestep  
       integer nymdmod           ! YYYYMMDD of the current model timestep  
       real      timebc1         ! YYYYMMDD.HHMMSS of the earlier bc data  
       real      timebc2         ! YYYYMMDD.HHMMSS of the later bc data  
       real      timemod         ! YYYYMMDD.HHMMSS of the current timestep  
       real      undef           ! Undefined value for missing data  
   
 C Define Allocatable Arrays  
       real, allocatable, save :: sstbc1(:,:)     ! Sea surface temperature (K) from bc data  
                                                  ! of the date before the model time  
       real, allocatable, save :: sstbc2(:,:)     ! Sea surface temperature (K) from bc data  
                                                  ! of the date after the model time  
387    
388  C--------- Variable Initialization ---------------------------------  C--------- Variable Initialization ---------------------------------
389    
# Line 457  C--------- Variable Initialization ----- Line 391  C--------- Variable Initialization -----
391        data error /.false./        data error /.false./
392    
393  c  save header info  c  save header info
394        save imbc, jmbc, lat0, lon0, ndatebc, undef, nymdbc, nhmsbc        save imbc,jmbc,npxbc,npybc,lat0,lon0,ndatebc,undef,nymdbc,nhmsbc
395        save nymdbc1, nymdbc2, nhmsbc1, nhmsbc2, sstbc1        save nymdbc1, nymdbc2, nhmsbc1, nhmsbc2
396        save first        save first
397          save sstbc1, sstbc2
398    
399  c  this only works for between 1950-2050  c  this only works for between 1950-2050
400        if (nymd .lt. 500101) then        if (nymd .lt. 500101) then
# Line 470  c  this only works for between 1950-2050 Line 405  c  this only works for between 1950-2050
405          nymdmod = nymd          nymdmod = nymd
406        endif        endif
407    
408          sstdata='sst19232.weekly.clim'
409    
410  c  initialize so that first time through they have values for the check  c  initialize so that first time through they have values for the check
411  c  these vaules make the iyear .ne. iyearbc true anyways for  c  these vaules make the iyear .ne. iyearbc true anyways for
412  c  for the first time so first isnt checked below.  c  for the first time so first isnt checked below.
413        if (first) then        if (first) then
       allocate ( sstbc1(lattice%imglobal,lattice%jmglobal) )  ! Allocate Memory for sstbc1  
       allocate ( sstbc2(lattice%imglobal,lattice%jmglobal) )  ! Allocate Memory for sstbc2  
414          nymdbc(2) = 0          nymdbc(2) = 0
415          nymdbc1   = 0          nymdbc1   = 0
416          nymdbc2   = 0          nymdbc2   = 0
# Line 490  C---------- Read in Header file -------- Line 425  C---------- Read in Header file --------
425        iyearbc = nymdbc(2)/10000        iyearbc = nymdbc(2)/10000
426    
427        if( iyear.ne.iyearbc ) then        if( iyear.ne.iyearbc ) then
         if( lattice%myid.eq.0 ) then    
428    
429          close(iunit)         close(iunit)
430          open (iunit, form='unformatted', access='direct',recl=lattice%imglobal*lattice%jmglobal*4)         open (iunit,file=sstdata,form='unformatted',access='direct',
431          nrec = 1       .                                        recl=im2*jm2*nPgx*nPgy*4)
432          call bcheader (iunit, ndmax, nrec,         nrec = 1
433       .                 cname, cdscrip, imbc, jmbc, lat0, lon0,         call bcheader (iunit, ndmax, nrec,
434       .                 ndatebc, nymdbc, nhmsbc, undef, error)       .          cname, cdscrip, imbc, jmbc, npxbc, npybc, lat0, lon0,
435         .          ndatebc, nymdbc, nhmsbc, undef, error)
436    
437  C--------- Check data for Compatibility  C--------- Check data for Compatibility
438    
439  C Check for correct data in boundary condition file  C Check for correct data in boundary condition file
440         if (.not.error .and. cname.ne.'SST') then         if (.not.error .and. cname.ne.'SST') then
441              write(6,*) 'Wrong data in SST boundary condition file => ',cname          write(6,*)'Wrong data in SST boundary condition file => ',cname
442              error = .true.          error = .true.
443         endif         endif
444    
445  C Check Horizontal Resolution  C Check Horizontal Resolution
446         if (.not.error .and. imbc*jmbc.ne.lattice%imglobal*lattice%jmglobal) then         if(.not.error.and.imbc*jmbc*npxbc*npybc.ne.im2*jm2*npgx*npgy)then
447              write(6,*) 'Boundary Condition Resolution DOES NOT match Model Resolution!'          write(6,*) ' B.C. Resolution DOES NOT match Model Resolution!'
448              write(6,*) 'Boundary Condition Resolution:  ',imbc*jmbc          write(6,*) ' B.C. Resolution:  ',imbc*jmbc*npxbc*npybc
449              write(6,*) '             Model Resolution:  ',lattice%imglobal*lattice%jmglobal          write(6,*) 'Model Resolution:  ',im2*jm2*npgx*npgy
450              error = .true.          error = .true.
451         endif         endif
452    
453  C Check Year  C Check Year
454         iyearbc = nymdbc(2)/10000         iyearbc = nymdbc(2)/10000
455         if (.not.error .and. iyear.ne.iyearbc .and. iyearbc.ne.0) then         if (.not.error .and. iyear.ne.iyearbc .and. iyearbc.ne.0) then
456              write(6,*) 'Boundary Condition Year DOES NOT match REQUESTED Year!'          write(6,*)'     B.C. Year DOES NOT match REQUESTED Year!'
457              write(6,*) 'Boundary Condition Year:  ', iyearbc          write(6,*)'     B.C. Year:  ', iyearbc
458              write(6,*) '         Requested Year:  ', iyear          write(6,*)'Requested Year:  ', iyear
459              error = .true.          error = .true.
460         endif         endif
461    
462         if (.not.error)   then         if (.not.error)   then
463  C if climatology, fill dates for data with current model year  C if climatology, fill dates for data with current model year
464              if (iyearbc.eq.0) then                        if (iyearbc.eq.0) then          
465              write(6,*)           write(6,*)
466              write(6,*) 'Climatological Dataset is being used.'             write(6,*)'Climatological Dataset is being used.'  
467              write(6,*) 'Current model year will be used to fill Header Dates'           write(6,*)'Current model year is used to fill Header Dates'
468                do n = 2, ndatebc-1           do n = 2, ndatebc-1
469                 nymdbc(n) = nymdbc(n) +(nymdmod/10000)*10000            nymdbc(n) = nymdbc(n) +(nymdmod/10000)*10000
470                enddo           enddo
471  C  For the first date subtract 1 year from the current model NYMD  C  For the first date subtract 1 year from the current model NYMD
472                n = 1           n = 1
473                nymdbc(n) = nymdbc(n) +(nymdmod/10000-1)*10000           nymdbc(n) = nymdbc(n) +(nymdmod/10000-1)*10000
474  C  For the last date add 1 year to the current model NYMD  C  For the last date add 1 year to the current model NYMD
475                n = ndatebc           n = ndatebc
476                nymdbc(n) = nymdbc(n) +(nymdmod/10000+1)*10000           nymdbc(n) = nymdbc(n) +(nymdmod/10000+1)*10000
477              endif          endif
478    
479  C  Write out header info  C  Write out header info
480         write(6,*) ' Updated boundary condition data'          write(6,*) ' Updated boundary condition data'
481         write(6,*) ' ---------------------------------'          write(6,*) ' ---------------------------------'
482         write(6,*) ' Variable: ',cname          write(6,*) ' Variable: ',cname
483         write(6,*) ' Description: ',cdscrip          write(6,*) ' Description: ',cdscrip
484         write(6,*) ' Resolution: x= ',imbc,' y= ',jmbc,' Undefined value = ',undef          write(6,*) ' Resolution: x= ',imbc,' y= ',jmbc,
485         write(6,*) ' Starting latitude = ',lat0,' longitude =',lon0       .                                       ' Undefined value = ',undef
486         write(6,*) ' Data valid at these times: '          write(6,*) ' Starting latitude = ',lat0,' longitude =',lon0
487         ndby3 = ndatebc/3          write(6,*) ' Data valid at these times: '
488         do n = 1, ndby3*3,3          ndby3 = ndatebc/3
489          write(6,1000) (nn,nymdbc(nn),nhmsbc(nn),nn=n,n+2)          do n = 1, ndby3*3,3
490   1000   format(3(2x,i3,':',i8,2x,i8))           write(6,1000) (nn,nymdbc(nn),nhmsbc(nn),nn=n,n+2)
491         enddo   1000    format(3(2x,i3,':',i8,2x,i8))
492         write(6,1000) (nn,nymdbc(nn),nhmsbc(nn),nn=ndby3*3+1,ndatebc)          enddo
493        endif  ! End error  Check          write(6,1000) (nn,nymdbc(nn),nhmsbc(nn),nn=ndby3*3+1,ndatebc)
494           endif
       endif  ! End MYID=0 Check  
495    
 c Broadcast information to other PEs  
 c ----------------------------------  
 #if (mpi)  
        call mpi_bcast ( error,1,mpi_logical,0,lattice%comm,ierror )  
 #endif  
496         if( error ) call my_exit (101)         if( error ) call my_exit (101)
497    
498  #if (mpi)        endif
        call mpi_bcast ( ndatebc,1     ,mpi_integer,0,lattice%comm,ierror )  
        call mpi_bcast ( nymdbc,ndatebc,mpi_integer,0,lattice%comm,ierror )  
        call mpi_bcast ( nhmsbc,ndatebc,mpi_integer,0,lattice%comm,ierror )  
 #endif  
   
       endif  ! New Year Info Check  
499    
500  C---------- Read SST data if necessary -------------------------------  C---------- Read SST data if necessary -------------------------------
501    
502          found = .false.        found = .false.
503          nd = 2        nd = 2
504    
505  c  If model time is not within the times of saved sst data  c  If model time is not within the times of saved sst data
506  c  from previous call to getsst then read new data  c  from previous call to getsst then read new data
507    
508          timemod = float(nymdmod) + float(nhms)   /1000000        timemod = float(nymdmod) + float(nhms)   /1000000
509          timebc1 = float(nymdbc1) + float(nhmsbc1)/1000000        timebc1 = float(nymdbc1) + float(nhmsbc1)/1000000
510          timebc2 = float(nymdbc2) + float(nhmsbc2)/1000000        timebc2 = float(nymdbc2) + float(nhmsbc2)/1000000
511          if (timemod .lt. timebc1 .or. timemod .ge. timebc2) then        if (timemod .lt. timebc1 .or. timemod .ge. timebc2) then
512    
513          do while (.not.found .and. nd .le. ndatebc)         do while (.not.found .and. nd .le. ndatebc)
514            timebc2 = float(nymdbc(nd)) + float(nhmsbc(nd))/1000000          timebc2 = float(nymdbc(nd)) + float(nhmsbc(nd))/1000000
515            if (timebc2 .gt. timemod) then                  if (timebc2 .gt. timemod) then  
516              nymdbc1 = nymdbc(nd-1)           nymdbc1 = nymdbc(nd-1)
517              nymdbc2 = nymdbc(nd)           nymdbc2 = nymdbc(nd)
518              nhmsbc1 = nhmsbc(nd-1)           nhmsbc1 = nhmsbc(nd-1)
519              nhmsbc2 = nhmsbc(nd)           nhmsbc2 = nhmsbc(nd)
520              if ( lattice%myid.eq.0 ) call bcdata (iunit, imbc, jmbc, nd, nd+1, sstbc1, sstbc2)           call bcdata (iunit,imbc,jmbc,nPgx,nPgy,nd,nd+1,sstbc1,sstbc2)
521  #if (mpi)           found = .true.
522              call mpi_bcast ( sstbc1,lattice%imglobal*lattice%jmglobal,mpi_double_precision,0,lattice%comm,ierror )          else
523              call mpi_bcast ( sstbc2,lattice%imglobal*lattice%jmglobal,mpi_double_precision,0,lattice%comm,ierror )           nd = nd + 1
524  #endif          endif
525              found = .true.         enddo
           else  
             nd = nd + 1  
           endif  
         enddo  
526    
527  c  Otherwise the data from the last time in getsst surrounds the  c  Otherwise the data from the last time in getsst surrounds the
528  c  current model time.  c  current model time.
529    
530          else        else
531            found = .true.         found = .true.
532          endif        endif
533    
534          if (.not.found) then        if (.not.found) then
535            if( lattice%myid.eq.0 ) print *, 'STOP: Could not find SST boundary condition dates surrounding the model time.'         print *, 'STOP: Could not find SST dates for model time.'
536            call my_finalize         call my_finalize
537            call my_exit (101)         call my_exit (101)
538          endif        endif
539    
540  C---------- Interpolate SST data ------------------------------------  C---------- Interpolate SST data ------------------------------------
541    
542            call interp_time ( nymdmod,nhms, nymdbc1,nhmsbc1, nymdbc2,nhmsbc2, fac1,fac2 )        call interp_time(nymdmod,nhms,nymdbc1,nhmsbc1,nymdbc2,nhmsbc2,
543         .                                                        fac1,fac2)
544    
545            do j = 1, jm        do j = jm1,jm2
546            do i = 1, im        do i = im1,im2
547              sst(i,j) = sstbc1( lattice%iglobal(i),lattice%jglobal(j) )*fac1         sst(i,j,bi,bj) = sstbc1(i,j,biglobal,bjglobal)*fac1
548       .               + sstbc2( lattice%iglobal(i),lattice%jglobal(j) )*fac2       .                + sstbc2(i,j,biglobal,bjglobal)*fac2
549            enddo        enddo
550            enddo        enddo
551    
552        return        return
553        end        end
554    
555        subroutine bcdata (iunit, im, jm, nrec1, nrec2, field1, field2)        subroutine bcdata (iunit,im,jm,nPx,nPy,nrec1,nrec2,field1,field2)
 C************************************************************************  
 C!BCDATA  
556  C************************************************************************  C************************************************************************
557  C  C
558  C!ROUTINE:      BCDATA  C!ROUTINE:      BCDATA
559  C!PROGRAMMER:   Sharon Nebuda  C!DESCRIPTION:  BCDATA reads the data from the file assigned to the
560  C!DATE CODED:   April 29, 1996  C!              passed unit number and returns data from the two times
561  C!DESCRIPTION:  BCDATA reads the data from the file assigned to the  C!              surrounding the current model time.  The two record
562  C!              passed unit number and returns data from the two times  C!              postitions are not assumed to be next to each other.
 C!              surrounding the current model time.  The two record  
 C!              postitions are not assumed to be next to each other.  
563  C  C
564  C!INPUT PARAMETERS:  C!INPUT PARAMETERS:
565  C!      im      number of x points  C!      im      number of x points
566  C!      jm      number of y points  C!      im      number of x points
567  C!      nrec1   record number of the time before the model time  C!      nPx     number of faces in x-direction
568  C!      nrec2   record number of the time after the model time  C!      nPy     number of faces in y-direction
569    C!      nrec1   record number of the time before the model time
570    C!      nrec2   record number of the time after the model time
571  C  C
572  C!OUTPUT PARAMETERS:  C!OUTPUT PARAMETERS:
573  C!      field1(im,jm)   data field before the model time  C!      field1(im,jm,nPx,nPy)  data field before the model time
574  C!      field2(im,jm)   data field after the model time  C!      field2(im,jm,nPx,nPy)  data field after the model time
 C  
 C!REVISION HISTORY:      
 C!      NEW  
 C  
 C!ROUTINES CALLED:  
 C  
 C!      none  
575  C  C
576  C--------------------------------------------------------------------------  C--------------------------------------------------------------------------
577          implicit none
578    
579          integer iunit,im,jm,nPx,nPy,nrec1,nrec2
580    
581  C--------------- Variable Declaration -------------------------------------        _RL  field1(im,jm,nPx,nPy)
582        implicit none        _RL  field2(im,jm,nPx,nPy)
583    
584  C  Variables passed to the routine:        integer i,j,n1,n2
585        integer   iunit   ! Unit number assigned to the data file        real*4 f1(im,jm,nPx,nPy), f2(im,jm,nPx,nPy)
       integer   im      ! Number of x points  
       integer   jm      ! Number of y points  
       integer   nrec1   ! Record number of the time before the model time  
       integer   nrec2   ! Record number of the time after the model time  
   
 C  Variables returned by the routine:  
       real      field1(im,jm)   ! Real*8 Data before the model time  
       real      field2(im,jm)   ! Real*8 Data after  the model time  
   
 C  Variables unique to the routine:  
       integer i,j               ! DO loop counters  
       real*4    f1(im,jm)       ! Real*4 Data before the model time  
       real*4    f2(im,jm)       ! Real*4 Data after  the model time  
586    
587  C--------- Read file -----------------------------------------------  C--------- Read file -----------------------------------------------
   
588        read(iunit,rec=nrec1) f1        read(iunit,rec=nrec1) f1
589        read(iunit,rec=nrec2) f2        read(iunit,rec=nrec2) f2
590    
591          do n2=1,nPy
592          do n1=1,nPx
593    #ifdef _BYTESWAPIO
594          call MDS_BYTESWAPR4( im*jm, f1(1,1,n1,n2))
595          call MDS_BYTESWAPR4( im*jm, f2(1,1,n1,n2))
596    #endif
597        do j=1,jm        do j=1,jm
598        do i=1,im        do i=1,im
599        field1(i,j) = f1(i,j)         field1(i,j,n1,n2) = f1(i,j,n1,n2)
600        field2(i,j) = f2(i,j)         field2(i,j,n1,n2) = f2(i,j,n1,n2)
601          enddo
602          enddo
603        enddo        enddo
604        enddo        enddo
605    
606        return        return
607        end        end
608        subroutine bcheader (iunit, ndmax, nrec,        subroutine bcheader (iunit, ndmax, nrec,
609       .                     cname, cdscrip, im, jm, lat0, lon0, ndatebc,       .           cname, cdscrip, im, jm, npx, npy, lat0, lon0, ndatebc,
610       .                     nymdbc, nhmsbc, undef, error)       .           nymdbc, nhmsbc, undef, error)
 C************************************************************************  
 C!BCHEADER  
611  C************************************************************************  C************************************************************************
612  C  C
613  C!ROUTINE:      BCHEADER  C!ROUTINE:     BCHEADER
614  C!PROGRAMMER:   Sharon Nebuda  C!DESCRIPTION: BCHEADER reads the header from a file and returns the info.  
 C!DATE CODED:   April 29, 1996  
 C!DESCRIPTION:  BCHEADER reads the header info from the file assigned to the  
 C!              passed unit number and returns the info back.    
615  C  C
616  C!INPUT PARAMETERS:  C!INPUT PARAMETERS:
617  C!      iunit   unit number assigned to the data file  C!      iunit    unit number assigned to the data file
618  C!      ndmax   maximum number of date/times of the data  C!      ndmax    maximum number of date/times of the data
619  C!      nrec    record number of the header info (or assume 1??)  C!      nrec     record number of the header info (or assume 1??)
620  C  C
621  C!OUTPUT PARAMETERS:  C!OUTPUT PARAMETERS:
622  C!      cname           name of the data in the file header  C!      cname         name of the data in the file header
623  C!      cdscrip         description of the data in the file header  C!      cdscrip       description of the data in the file header
624  C!      im              number of x points  C!      im            number of x points
625  C!      jm              number of y points  C!      jm            number of y points
626  C!      lat0            starting latitude for the data grid  C!      npx           number of faces (processors) in x-direction
627  C!      lon0            starting longitude for the data grid  C!      npy           number of faces (processors) in x-direction
628  C!      ndatebc         number of date/times of the data in the file  C!      lat0          starting latitude for the data grid
629  C!      nymdbc(ndmax)   array of dates for the data including century  C!      lon0          starting longitude for the data grid
630  C!      nhmsbc(ndmax)   array of times for the data  C!      ndatebc       number of date/times of the data in the file
631  C!      undef           value for undefined values in the data  C!      nymdbc(ndmax) array of dates for the data including century
632  C!      error           logical TRUE if dataset problem  C!      nhmsbc(ndmax) array of times for the data
633  C  C!      undef         value for undefined values in the data
634  C!REVISION HISTORY:      C!      error         logical TRUE if dataset problem
 C!      NEW  
 C  
 C!ROUTINES CALLED:  
 C!      none  
635  C  C
636  C--------------------------------------------------------------------------  C--------------------------------------------------------------------------
   
 C--------------- Variable Declaration -------------------------------------  
637        implicit none        implicit none
638    
639  C  Variables passed to the routine:        integer iunit, ndmax, nrec
       integer   iunit   ! Unit number assigned to the data file  
       integer   ndmax   ! Maximum number of dates for a given field  
       integer   nrec    ! Record number of the header info (or assume 1??)  
   
 C  Variables returned by the routine:  
       character*8  cname        ! Name of the data in the file header  
       character*80 cdscrip      ! Description of the data in the file header  
       integer   im     ! Number of x points  
       integer   jm     ! Number of y points  
       real         lat0     ! Starting latitude of the data  
       real           lon0     ! Starting longitude of the data  
       integer   ndatebc ! Number of date/times of the data in the file  
       integer   nymdbc(ndmax)   ! array of dates for the data including century  
       integer   nhmsbc(ndmax)   ! array of times for the data  
       real      undef           ! value for undefined values in the data  
       logical error         ! logical TRUE if dataset problem  
640    
641  C  Variables unique to the routine:        character*8  cname
642        integer   i               ! DO loop counters        character*80 cdscrip
643        integer n        integer im,jm,npx,npy,ndatebc,nymdbc(ndmax),nhmsbc(ndmax)
644        integer*4            im_32  ! Number of x points        _RL lat0,lon0,undef
645        integer*4               jm_32  ! Number of y points        logical error
646        real*4             lat0_32  ! Starting latitude of the data  
647        real*4               lon0_32  ! Starting longitude of the data        integer i
648        integer*4       ndatebc_32  ! Number of date/times of the data in the file        integer*4 im_32,jm_32,npx_32,npy_32
649        integer*4 nymdbc_32(ndmax)  ! array of dates for the data including century        integer*4 ndatebc_32,nhmsbc_32(ndmax),nymdbc_32(ndmax)
650        integer*4 nhmsbc_32(ndmax)  ! array of times for the data        real*4 lat0_32,lon0_32,undef_32
       real*4     undef_32         ! value for undefined values in the data  
651    
652  C--------- Read file -----------------------------------------------  C--------- Read file -----------------------------------------------
653    
654        read(iunit,rec=nrec,err=500) cname, cdscrip,        read(iunit,rec=nrec,err=500) cname, cdscrip,
655       .                     im_32, jm_32, lat0_32, lon0_32,       .     im_32, jm_32, npx_32, npy_32, lat0_32, lon0_32,
656       .                     ndatebc_32, undef_32,       .     ndatebc_32, undef_32,
657       .                    (nymdbc_32(i), nhmsbc_32(i), i=1,ndatebc_32)       .     (nymdbc_32(i), nhmsbc_32(i), i=1,ndatebc_32)
658    #ifdef _BYTESWAPIO
659        im    =    im_32        call MDS_BYTESWAPI4( 1, im_32)
660        jm    =    jm_32        call MDS_BYTESWAPI4( 1, jm_32)
661        lat0  =  lat0_32        call MDS_BYTESWAPR4( 1, lat0_32)
662        lon0  =  lon0_32        call MDS_BYTESWAPR4( 1, lon0_32)
663          call MDS_BYTESWAPR4( 1, undef_32)
664    #endif
665    
666          print *,' Read header: ',cname, cdscrip
667          print *,' Read header: ',im_32, jm_32
668          print *,' Read header: ',npx_32, npy_32
669          im = im_32
670          jm = jm_32
671          npx = npx_32
672          npy = npy_32
673          lat0 = lat0_32
674          lon0 = lon0_32
675        undef = undef_32        undef = undef_32
676    
677        ndatebc = ndatebc_32        ndatebc = ndatebc_32
# Line 795  C--------- Read file ------------------- Line 686  C--------- Read file -------------------
686        error = .true.        error = .true.
687        return        return
688        end        end
689    
690    #include "MDSIO_OPTIONS.h"
691    
692          subroutine MDS_BYTESWAPI4( n, arr )
693    C IN:
694    C   n           integer - Number of 4-byte words in arr
695    C IN/OUT:
696    C   arr         integer*4  - Array declared as integer*4(n)
697    C
698    C Created: 05/05/99 adcroft@mit.edu (This is an unfortunate hack!!)
699    
700          implicit none
701    C Arguments
702          integer n
703          character*(*) arr
704    C Local
705          integer i
706          character*(1) cc
707    C     ------------------------------------------------------------------
708          do i=1,4*n,4
709           cc=arr(i:i)
710           arr(i:i)=arr(i+3:i+3)
711           arr(i+3:i+3)=cc
712           cc=arr(i+1:i+1)
713           arr(i+1:i+1)=arr(i+2:i+2)
714           arr(i+2:i+2)=cc
715          enddo
716    C     ------------------------------------------------------------------
717          return
718          end
Legend:
Removed from v.1.3  
changed lines
  Added in v.1.18
  ViewVC Help
Powered by ViewVC 1.1.22