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

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

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

revision 1.2 by heimbach, Sat Jul 13 02:47:32 2002 UTC revision 1.17 by heimbach, Thu Jun 14 18:55:36 2007 UTC
# Line 1  Line 1 
1    
2  #include "CTRL_CPPOPTIONS.h"  #include "CTRL_CPPOPTIONS.h"
3    
   
4        subroutine ctrl_set_unpack_xyz(        subroutine ctrl_set_unpack_xyz(
5       &     cunit, ivartype, fname, masktype,       &     lxxadxx, cunit, ivartype, fname, masktype, weighttype,
6       &     weightfld, nwetglobal, mythid)       &     weightfld, nwetglobal, mythid)
7    
8  c     ==================================================================  c     ==================================================================
9  c     SUBROUTINE ctrl_set_unpack_xyz  c     SUBROUTINE ctrl_set_unpack_xyz
10  c     ==================================================================  c     ==================================================================
11  c  c
12  c     o Unpack the control vector such that the land points are filled  c     o Unpack the control vector such that land points are filled in.
13  c       in.  c
14    c     o Use a more precise nondimensionalization that depends on (x,y)
15    c       Added weighttype to the argument list so that I can geographically
16    c       vary the nondimensionalization.
17    c       gebbie@mit.edu, 18-Mar-2003
18  c  c
19  c     ==================================================================  c     ==================================================================
20    
# Line 25  c     == global variables == Line 28  c     == global variables ==
28  #include "GRID.h"  #include "GRID.h"
29    
30  #include "ctrl.h"  #include "ctrl.h"
 #include "cost.h"  
   
 #ifdef ALLOW_ECCO_OPTIMIZATION  
31  #include "optim.h"  #include "optim.h"
 #endif  
32    
33  c     == routine arguments ==  c     == routine arguments ==
34    
35          logical lxxadxx
36        integer cunit        integer cunit
37        integer ivartype        integer ivartype
38        character*( 80)   fname        character*( 80)   fname
39        character*  (5) masktype        character*(  9) masktype
40          character*( 80) weighttype
41        _RL     weightfld( nr,nsx,nsy )        _RL     weightfld( nr,nsx,nsy )
42        integer nwetglobal(nr)        integer nwetglobal(nr)
43        integer mythid        integer mythid
44    
45    #ifndef EXCLUDE_CTRL_PACK
46  c     == local variables ==  c     == local variables ==
47    
 #ifndef ALLOW_ECCO_OPTIMIZATION  
       integer optimcycle  
 #endif  
   
48        integer bi,bj        integer bi,bj
49        integer ip,jp        integer ip,jp
50        integer i,j,k        integer i,j,k
# Line 60  c     == local variables == Line 58  c     == local variables ==
58    
59        integer cbuffindex        integer cbuffindex
60    
       _RL     cbuff    ( snx*nsx*npx*sny*nsy*npy )  
61        _RL     globmsk  ( snx,nsx,npx,sny,nsy,npy,nr )        _RL     globmsk  ( snx,nsx,npx,sny,nsy,npy,nr )
62        _RL     globfld3d( snx,nsx,npx,sny,nsy,npy,nr )        _RL     globfld3d( snx,nsx,npx,sny,nsy,npy,nr )
63    #ifdef CTRL_UNPACK_PRECISE
64          _RL   weightfld3d( snx,nsx,npx,sny,nsy,npy,nr )
65    #endif
66          real*4 cbuff      ( snx*nsx*npx*sny*nsy*npy )
67          real*4 globfldtmp2( snx,nsx,npx,sny,nsy,npy )
68          real*4 globfldtmp3( snx,nsx,npx,sny,nsy,npy )
69    
70        character*(128)   cfile        character*(128)   cfile
71          character*(80) weightname
72    
73        integer        filenvartype        _RL delZnorm
74        integer        filenvarlength        integer reclen, irectrue
75        character*(10) fileExpId        integer cunit2, cunit3
76        integer        fileOptimCycle        character*(80) cfile2, cfile3
       integer        filencbuffindex  
       _RL            fileDummy  
       integer        fileIg  
       integer        fileJg  
       integer        fileI  
       integer        fileJ  
       integer        filensx  
       integer        filensy  
       integer        filek  
       integer        filencvarindex(maxcvars)  
       integer        filencvarrecs(maxcvars)  
       integer        filencvarxmax(maxcvars)  
       integer        filencvarymax(maxcvars)  
       integer        filencvarnrmax(maxcvars)  
       character*( 1) filencvargrd(maxcvars)  
77    
78  c     == external ==  c     == external ==
79    
# Line 102  cc     == end of interface == Line 91  cc     == end of interface ==
91        imin = 1        imin = 1
92        imax = snx        imax = snx
93    
94    #ifdef CTRL_DELZNORM
95          delZnorm = 0.
96          do k = 1, Nr
97             delZnorm = delZnorm + delR(k)/FLOAT(Nr)
98          enddo
99    #endif
100    
101  c     Initialise temporary file  c     Initialise temporary file
102        do k = 1,nr        do k = 1,nr
103           do jp = 1,nPy           do jp = 1,nPy
# Line 110  c     Initialise temporary file Line 106  c     Initialise temporary file
106                    do ip = 1,nPx                    do ip = 1,nPx
107                       do bi = itlo,ithi                       do bi = itlo,ithi
108                          do i = imin,imax                          do i = imin,imax
109                             globfld3d(i,bi,ip,j,bj,jp,k) = 0. _d 0                             globfld3d  (i,bi,ip,j,bj,jp,k) = 0. _d 0
110                             globmsk  (i,bi,ip,j,bj,jp,k) = 0. _d 0                             globmsk    (i,bi,ip,j,bj,jp,k) = 0. _d 0
111                               globfldtmp2(i,bi,ip,j,bj,jp)   = 0.
112                               globfldtmp3(i,bi,ip,j,bj,jp)   = 0.
113                          enddo                          enddo
114                       enddo                       enddo
115                    enddo                    enddo
# Line 120  c     Initialise temporary file Line 118  c     Initialise temporary file
118           enddo           enddo
119        enddo        enddo
120    
 #ifndef ALLOW_ECCO_OPTIMIZATION  
       optimcycle = 0  
 #endif  
   
121  c--   Only the master thread will do I/O.  c--   Only the master thread will do I/O.
122        _BEGIN_MASTER( mythid )        _BEGIN_MASTER( mythid )
123    
124    #ifdef CTRL_DELZNORM
125          do k = 1, nr
126             print *, 'ph-delznorm ', k, delZnorm, delR(k)
127             print *, 'ph-weight   ', weightfld(k,1,1)
128          enddo
129    #endif
130    
131          if ( doPackDiag ) then
132             write(cfile2(1:80),'(80a)') ' '
133             write(cfile3(1:80),'(80a)') ' '
134             if ( lxxadxx ) then
135                write(cfile2(1:80),'(a,I2.2,a,I4.4,a)')
136         &           'diag_unpack_nondim_ctrl_',
137         &           ivartype, '_', optimcycle, '.bin'
138                write(cfile3(1:80),'(a,I2.2,a,I4.4,a)')
139         &           'diag_unpack_dimens_ctrl_',
140         &           ivartype, '_', optimcycle, '.bin'
141             else
142                write(cfile2(1:80),'(a,I2.2,a,I4.4,a)')
143         &           'diag_unpack_nondim_grad_',
144         &           ivartype, '_', optimcycle, '.bin'
145                write(cfile3(1:80),'(a,I2.2,a,I4.4,a)')
146         &           'diag_unpack_dimens_grad_',
147         &           ivartype, '_', optimcycle, '.bin'
148             endif
149    
150             reclen = FLOAT(snx*nsx*npx*sny*nsy*npy*4)
151             call mdsfindunit( cunit2, mythid )
152             open( cunit2, file=cfile2, status='unknown',
153         &        access='direct', recl=reclen )
154             call mdsfindunit( cunit3, mythid )
155             open( cunit3, file=cfile3, status='unknown',
156         &        access='direct', recl=reclen )
157          endif
158    
159    #ifdef CTRL_UNPACK_PRECISE
160          il=ilnblnk( weighttype)
161          write(weightname(1:80),'(80a)') ' '
162          write(weightname(1:80),'(a)') weighttype(1:il)
163    
164          call MDSREADFIELD_3D_GL(
165         &     weightname, ctrlprec, 'RL',
166         &     Nr, weightfld3d, 1, mythid)
167    #endif
168    
169        call MDSREADFIELD_3D_GL(        call MDSREADFIELD_3D_GL(
170       &     masktype, ctrlprec, 'RL',       &     masktype, ctrlprec, 'RL',
171       &     Nr, globmsk, 1, mythid)       &     Nr, globmsk, 1, mythid)
172    
173        do irec = 1, ncvarrecs(ivartype)        do irec = 1, ncvarrecs(ivartype)
174    #ifndef ALLOW_ADMTLM
175           read(cunit) filencvarindex(ivartype)           read(cunit) filencvarindex(ivartype)
176           if (filencvarindex(ivartype) .NE. ncvarindex(ivartype))           if (filencvarindex(ivartype) .NE. ncvarindex(ivartype))
177       &        then       &        then
# Line 141  c--   Only the master thread will do I/O Line 181  c--   Only the master thread will do I/O
181           endif           endif
182           read(cunit) filej           read(cunit) filej
183           read(cunit) filei           read(cunit) filei
184    #endif /* ALLOW_ADMTLM */
185           do k = 1, Nr           do k = 1, Nr
186             irectrue = (irec-1)*nr + k
187                if ( doZscaleUnpack ) then
188                   delZnorm = (delR(1)/delR(k))**delZexp
189                else
190                   delZnorm = 1. _d 0
191                endif
192              cbuffindex = nwetglobal(k)              cbuffindex = nwetglobal(k)
193              if ( cbuffindex .gt. 0 ) then              if ( cbuffindex .gt. 0 ) then
194    #ifndef ALLOW_ADMTLM
195                 read(cunit) filencbuffindex                 read(cunit) filencbuffindex
196                 if (filencbuffindex .NE. cbuffindex) then                 if (filencbuffindex .NE. cbuffindex) then
197                    print *, 'WARNING: wrong cbuffindex ',                    print *, 'WARNING: wrong cbuffindex ',
# Line 156  c--   Only the master thread will do I/O Line 204  c--   Only the master thread will do I/O
204       &                 filek, k       &                 filek, k
205                    STOP 'in S/R ctrl_unpack'                    STOP 'in S/R ctrl_unpack'
206                 endif                 endif
207    cph#endif /* ALLOW_ADMTLM */
208                 read(cunit) (cbuff(ii), ii=1,cbuffindex)                 read(cunit) (cbuff(ii), ii=1,cbuffindex)
209    #endif /* ALLOW_ADMTLM */
210              endif              endif
211    c
212              cbuffindex = 0              cbuffindex = 0
213              do jp = 1,nPy              do jp = 1,nPy
214               do bj = jtlo,jthi               do bj = jtlo,jthi
# Line 168  c--   Only the master thread will do I/O Line 219  c--   Only the master thread will do I/O
219                    if ( globmsk(i,bi,ip,j,bj,jp,k) .ne. 0. ) then                    if ( globmsk(i,bi,ip,j,bj,jp,k) .ne. 0. ) then
220                       cbuffindex = cbuffindex + 1                       cbuffindex = cbuffindex + 1
221                       globfld3d(i,bi,ip,j,bj,jp,k) = cbuff(cbuffindex)                       globfld3d(i,bi,ip,j,bj,jp,k) = cbuff(cbuffindex)
222  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  cph(
223                         globfldtmp2(i,bi,ip,j,bj,jp) = cbuff(cbuffindex)
224    cph)
225    #ifdef ALLOW_ADMTLM
226                         nveccount = nveccount + 1
227                       globfld3d(i,bi,ip,j,bj,jp,k) =                       globfld3d(i,bi,ip,j,bj,jp,k) =
228       &                    globfld3d(i,bi,ip,j,bj,jp,k)/       &                 phtmpadmtlm(nveccount)
229       &                    sqrt(weightfld(k,bi,bj))  cph(
230                         globfldtmp2(i,bi,ip,j,bj,jp) =
231         &                 phtmpadmtlm(nveccount)
232    cph)
233  #endif  #endif
234    #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO
235                         if ( lxxadxx ) then
236                            globfld3d(i,bi,ip,j,bj,jp,k) = delZnorm
237         &                       * globfld3d(i,bi,ip,j,bj,jp,k)
238    # ifdef CTRL_UNPACK_PRECISE
239         &                       / sqrt(weightfld3d(i,bi,ip,j,bj,jp,k))
240    # else
241         &                       / sqrt(weightfld(k,bi,bj))
242    # endif
243                         else
244                            globfld3d(i,bi,ip,j,bj,jp,k) = delZnorm
245         &                       * globfld3d(i,bi,ip,j,bj,jp,k)
246    # ifdef CTRL_UNPACK_PRECISE
247         &                       * sqrt(weightfld3d(i,bi,ip,j,bj,jp,k))
248    # else
249         &                       * sqrt(weightfld(k,bi,bj))
250    # endif
251                         endif
252    #endif /* ALLOW_NONDIMENSIONAL_CONTROL_IO */
253                    else                    else
254                       globfld3d(i,bi,ip,j,bj,jp,k) = 0. _d 0                       globfld3d(i,bi,ip,j,bj,jp,k) = 0. _d 0
255                    endif                    endif
256    cph(
257                      globfldtmp3(i,bi,ip,j,bj,jp) =
258         &                 globfld3d(i,bi,ip,j,bj,jp,k)
259    cph)
260                   enddo                   enddo
261                  enddo                  enddo
262                 enddo                 enddo
# Line 183  c--   Only the master thread will do I/O Line 264  c--   Only the master thread will do I/O
264               enddo               enddo
265              enddo              enddo
266  c  c
267                if ( doPackDiag ) then
268                   write(cunit2,rec=irectrue) globfldtmp2
269                   write(cunit3,rec=irectrue) globfldtmp3
270                endif
271    c
272           enddo           enddo
273                            
274           call MDSWRITEFIELD_3D_GL( fname, ctrlprec, 'RL',           call MDSWRITEFIELD_3D_GL( fname, ctrlprec, 'RL',
# Line 191  c Line 277  c
277    
278        enddo        enddo
279    
280          if ( doPackDiag ) then
281             close ( cunit2 )
282             close ( cunit3 )
283          endif
284    
285        _END_MASTER( mythid )        _END_MASTER( mythid )
286    
287    #endif
288    
289        return        return
290        end        end
291    
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.17
  ViewVC Help
Powered by ViewVC 1.1.22