/[MITgcm]/MITgcm/pkg/ctrl/ctrl_set_unpack_yz.F
ViewVC logotype

Diff of /MITgcm/pkg/ctrl/ctrl_set_unpack_yz.F

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

revision 1.1 by heimbach, Tue Feb 5 20:23:58 2002 UTC revision 1.1.2.8 by heimbach, Thu Sep 25 22:13:44 2003 UTC
# Line 0  Line 1 
1    
2    #include "CTRL_CPPOPTIONS.h"
3    
4    
5          subroutine ctrl_set_unpack_yz(
6         &     cunit, ivartype, fname, masktype, weighttype,
7         &     weightfld, nwetglobal, mythid)
8    
9    c     ==================================================================
10    c     SUBROUTINE ctrl_set_unpack_yz
11    c     ==================================================================
12    c
13    c     o Unpack the control vector such that land points are filled in.
14    c
15    c     o Open boundary packing added :
16    c          gebbie@mit.edu, 18-Mar-2003
17    c
18    c     changed: heimbach@mit.edu 17-Jun-2003
19    c              merged Armin's changes to replace write of
20    c              nr * globfld2d by 1 * globfld3d
21    c              (ad hoc fix to speed up global I/O)
22    c
23    c     ==================================================================
24    
25          implicit none
26    
27    c     == global variables ==
28    
29    #include "EEPARAMS.h"
30    #include "SIZE.h"
31    #include "PARAMS.h"
32    #include "GRID.h"
33    
34    #include "ctrl.h"
35    #include "cost.h"
36    
37    #ifdef ALLOW_ECCO_OPTIMIZATION
38    #include "optim.h"
39    #endif
40    
41    c     == routine arguments ==
42    
43          integer cunit
44          integer ivartype
45          character*( 80)   fname
46          character*  (9) masktype
47          character*( 80) weighttype
48          _RL     weightfld( nr,nobcs )
49          integer nwetglobal(nr,nobcs)
50          integer mythid
51    
52    c     == local variables ==
53    
54    #ifndef ALLOW_ECCO_OPTIMIZATION
55          integer optimcycle
56    #endif
57    
58          integer bi,bj
59          integer ip,jp
60          integer i,j,k
61          integer ii,jj,kk
62          integer il
63          integer irec,iobcs,nrec_nl
64          integer itlo,ithi
65          integer jtlo,jthi
66          integer jmin,jmax
67          integer imin,imax
68    
69          integer cbuffindex
70    
71          real*4     cbuff    ( nsx*npx*sny*nsy*npy )
72          _RL     globfldyz( nsx,npx,sny,nsy,npy,nr )
73          _RL     globfld3d( snx,nsx,npx,sny,nsy,npy,nr )
74          _RL     globmskyz( nsx,npx,sny,nsy,npy,nr,nobcs )
75    #ifdef CTRL_UNPACK_PRECISE
76          _RL   weightfldyz( nsx,npx,sny,nsy,npy,nr,nobcs )
77    #endif
78    
79          integer        filenvartype
80          integer        filenvarlength
81          character*(10) fileExpId
82          integer        fileOptimCycle
83          integer        filencbuffindex
84          _RL            fileDummy
85          integer        fileIg
86          integer        fileJg
87          integer        fileI
88          integer        fileJ
89          integer        filensx
90          integer        filensy
91          integer        filek
92          integer        filencvarindex(maxcvars)
93          integer        filencvarrecs(maxcvars)
94          integer        filencvarxmax(maxcvars)
95          integer        filencvarymax(maxcvars)
96          integer        filencvarnrmax(maxcvars)
97          character*( 1) filencvargrd(maxcvars)
98    cgg(
99          integer igg
100          _RL     gg
101          character*(80) weightname
102    cgg)
103    
104    c     == external ==
105    
106          integer  ilnblnk
107          external ilnblnk
108    
109    cc     == end of interface ==
110    
111          jtlo = 1
112          jthi = nsy
113          itlo = 1
114          ithi = nsx
115          jmin = 1
116          jmax = sny
117          imin = 1
118          imax = snx
119    
120    c     Initialise temporary file
121          do k = 1,nr
122             do jp = 1,nPy
123                do bj = jtlo,jthi
124                   do j = jmin,jmax
125                      do ip = 1,nPx
126                         do bi = itlo,ithi
127                            globfldyz(bi,ip,j,bj,jp,k) = 0. _d 0
128                            do iobcs=1,nobcs
129                               globmskyz(bi,ip,j,bj,jp,k,iobcs) = 0. _d 0
130                            enddo
131                         enddo
132                      enddo
133                   enddo
134                enddo
135             enddo
136          enddo
137    c     Initialise temporary file
138          do k = 1,nr
139             do jp = 1,nPy
140                do bj = jtlo,jthi
141                   do j = jmin,jmax
142                      do ip = 1,nPx
143                         do bi = itlo,ithi
144                            do i = imin,imax
145                               globfld3d(i,bi,ip,j,bj,jp,k) = 0. _d 0
146                            enddo
147                         enddo
148                      enddo
149                   enddo
150                enddo
151             enddo
152          enddo
153    
154    #ifndef ALLOW_ECCO_OPTIMIZATION
155          optimcycle = 0
156    #endif
157    
158    c--   Only the master thread will do I/O.
159          _BEGIN_MASTER( mythid )
160    
161          do iobcs=1,nobcs
162             call MDSREADFIELD_YZ_GL(
163         &        masktype, ctrlprec, 'RL',
164         &        Nr, globmskyz(1,1,1,1,1,1,iobcs), iobcs, mythid)
165    #ifdef CTRL_UNPACK_PRECISE
166             il=ilnblnk( weighttype)
167             write(weightname(1:80),'(80a)') ' '
168             write(weightname(1:80),'(a)') weighttype(1:il)
169             call MDSREADFIELD_YZ_GL(
170         &       weightname, ctrlprec, 'RL',
171         &       Nr, weightfldyz(1,1,1,1,1,1,iobcs), iobcs, mythid)
172    CGG   One special exception: barotropic velocity should be nondimensionalized
173    cgg   differently. Probably introduce new variable.
174             if (iobcs .eq. 3 .or. iobcs .eq. 4) then
175                k = 1
176                do jp = 1,nPy
177                   do bj = jtlo,jthi
178                      do j = jmin,jmax
179                         do ip = 1,nPx
180                            do bi = itlo,ithi
181                               weightfldyz(bi,ip,j,bj,jp,k,iobcs) = wbaro
182                            enddo
183                         enddo
184                      enddo
185                   enddo
186                enddo
187             endif
188    #endif
189          enddo
190    
191          nrec_nl=int(ncvarrecs(ivartype)/snx)
192          do irec = 1, nrec_nl
193    cgg      do iobcs = 1, nobcs
194    cgg      And now back-calculate what iobcs should be.
195             do i=1,snx
196                iobcs= mod((irec-1)*snx+i-1,nobcs)+1
197    
198                read(cunit) filencvarindex(ivartype)
199                if (filencvarindex(ivartype) .NE. ncvarindex(ivartype))
200         &           then
201                   print *, 'ctrl_set_unpack_yz:WARNING: wrong ncvarindex ',
202         &              filencvarindex(ivartype), ncvarindex(ivartype)
203                   STOP 'in S/R ctrl_unpack'
204                endif
205                read(cunit) filej
206                read(cunit) filei
207                do k = 1, Nr
208                   cbuffindex = nwetglobal(k,iobcs)
209                   if ( cbuffindex .gt. 0 ) then
210                      read(cunit) filencbuffindex
211                      if (filencbuffindex .NE. cbuffindex) then
212                         print *, 'WARNING: wrong cbuffindex ',
213         &                    filencbuffindex, cbuffindex
214                         STOP 'in S/R ctrl_unpack'
215                      endif
216                      read(cunit) filek
217                      if (filek .NE. k) then
218                         print *, 'WARNING: wrong k ',
219         &                    filek, k
220                         STOP 'in S/R ctrl_unpack'
221                      endif
222                      read(cunit) (cbuff(ii), ii=1,cbuffindex)
223                   endif
224                   cbuffindex = 0
225                   do jp = 1,nPy
226                    do bj = jtlo,jthi
227                     do j = jmin,jmax
228                      do ip = 1,nPx
229                       do bi = itlo,ithi
230                        ii=mod((i-1)*nr*sny+(k-1)*sny+j-1,snx)+1
231                        jj=mod(((i-1)*nr*sny+(k-1)*sny+j-1)/snx,sny)+1
232                        kk=int((i-1)*nr*sny+(k-1)*sny+j-1)/(snx*sny)+1
233                        if ( globmskyz(bi,ip,j,bj,jp,k,iobcs) .ne. 0. ) then
234                           cbuffindex = cbuffindex + 1
235                           globfld3d(ii,bi,ip,jj,bj,jp,kk) =
236         &                      cbuff(cbuffindex)
237    #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO
238                           globfld3d(ii,bi,ip,jj,bj,jp,kk) =
239         &                      globfld3d(ii,bi,ip,jj,bj,jp,kk)/
240    # ifdef CTRL_UNPACK_PRECISE
241         &                      sqrt(weightfldyz(bi,ip,j,bj,jp,k,iobcs))
242    # else
243         &                      sqrt(weightfld(k,iobcs))
244    # endif
245    #endif /* ALLOW_NONDIMENSIONAL_CONTROL_IO */
246                        else
247                           globfld3d(ii,bi,ip,jj,bj,jp,kk) = 0. _d 0
248                        endif
249                       enddo
250                      enddo
251                     enddo
252                    enddo
253                   enddo
254    c
255    c     -- end of k loop --
256                enddo
257    c     -- end of i loop --
258             enddo
259    
260             call MDSWRITEFIELD_3d_GL( fname, ctrlprec, 'RL',
261         &                             Nr, globfld3d, irec,
262         &                             optimcycle, mythid)
263    
264    c     -- end of iobcs loop -- This loop has been removed.
265    cgg     enddo
266    c     -- end of irec loop --
267          enddo
268    
269          do irec = nrec_nl*snx+1,ncvarrecs(ivartype)
270             iobcs= mod(irec-1,nobcs)+1
271    
272             read(cunit) filencvarindex(ivartype)
273             if (filencvarindex(ivartype) .NE. ncvarindex(ivartype))
274         &        then
275                print *, 'ctrl_set_unpack_yz:WARNING: wrong ncvarindex ',
276         &           filencvarindex(ivartype), ncvarindex(ivartype)
277                STOP 'in S/R ctrl_unpack'
278             endif
279             read(cunit) filej
280             read(cunit) filei
281             do k = 1, Nr
282                cbuffindex = nwetglobal(k,iobcs)
283                if ( cbuffindex .gt. 0 ) then
284                   read(cunit) filencbuffindex
285                   if (filencbuffindex .NE. cbuffindex) then
286                      print *, 'WARNING: wrong cbuffindex ',
287         &                 filencbuffindex, cbuffindex
288                      STOP 'in S/R ctrl_unpack'
289                   endif
290                   read(cunit) filek
291                   if (filek .NE. k) then
292                      print *, 'WARNING: wrong k ',
293         &                 filek, k
294                      STOP 'in S/R ctrl_unpack'
295                   endif
296                   read(cunit) (cbuff(ii), ii=1,cbuffindex)
297                endif
298                cbuffindex = 0
299                do jp = 1,nPy
300                 do bj = jtlo,jthi
301                  do j = jmin,jmax
302                   do ip = 1,nPx
303                    do bi = itlo,ithi
304                      if ( globmskyz(bi,ip,j,bj,jp,k,iobcs) .ne. 0. ) then
305                         cbuffindex = cbuffindex + 1
306                         globfldyz(bi,ip,j,bj,jp,k) = cbuff(cbuffindex)
307    #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO
308                         globfldyz(bi,ip,j,bj,jp,k) =
309         &                    globfldyz(bi,ip,j,bj,jp,k)/
310    # ifdef CTRL_UNPACK_PRECISE
311         &                    sqrt(weightfldyz(bi,ip,j,bj,jp,k,iobcs))
312    # else
313         &                    sqrt(weightfld(k,iobcs))
314    # endif
315    #endif /* ALLOW_NONDIMENSIONAL_CONTROL_IO */
316                      else
317                         globfldyz(bi,ip,j,bj,jp,k) = 0. _d 0
318                      endif
319                    enddo
320                   enddo
321                  enddo
322                 enddo
323                enddo
324    c
325    c     -- end of k loop
326             enddo
327                
328             call MDSWRITEFIELD_YZ_GL( fname, ctrlprec, 'RL',
329         &                             Nr, globfldyz, irec,
330         &                             optimcycle, mythid)
331    
332    c     -- end of iobcs loop -- This loop has been removed.
333    cgg     enddo
334    c     -- end of irec loop --
335          enddo
336    
337          _END_MASTER( mythid )
338    
339          return
340          end
341    
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.1.2.8
  ViewVC Help
Powered by ViewVC 1.1.22