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

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

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

revision 1.6 by heimbach, Thu Oct 30 19:09:05 2003 UTC revision 1.15 by heimbach, Sat May 27 17:07:21 2006 UTC
# Line 1  Line 1 
 C  
 C $Header$  
 C $Name$  
1    
2  #include "CTRL_CPPOPTIONS.h"  #include "CTRL_CPPOPTIONS.h"
3    
   
4        subroutine ctrl_set_pack_xyz(        subroutine ctrl_set_pack_xyz(
5       &     cunit, ivartype, fname, masktype, weighttype,       &     cunit, ivartype, fname, masktype, weighttype,
6       &     weightfld, lxxadxx, mythid)       &     weightfld, lxxadxx, mythid)
# Line 33  c     == global variables == Line 29  c     == global variables ==
29  #include "GRID.h"  #include "GRID.h"
30    
31  #include "ctrl.h"  #include "ctrl.h"
 #include "cost.h"  
   
 #ifdef ALLOW_ECCO_OPTIMIZATION  
32  #include "optim.h"  #include "optim.h"
 #endif  
33    
34  c     == routine arguments ==  c     == routine arguments ==
35    
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        character*( 80) weighttype
41        _RL     weightfld( nr,nsx,nsy )        _RL     weightfld( nr,nsx,nsy )
42        logical lxxadxx        logical lxxadxx
# Line 52  c     == routine arguments == Line 44  c     == routine arguments ==
44    
45  c     == local variables ==  c     == local variables ==
46    
 #ifndef ALLOW_ECCO_OPTIMIZATION  
       integer optimcycle  
 #endif  
   
47        integer bi,bj        integer bi,bj
48        integer ip,jp        integer ip,jp
49        integer i,j,k        integer i,j,k
# Line 69  c     == local variables == Line 57  c     == local variables ==
57    
58        integer cbuffindex        integer cbuffindex
59    
       _RL     cbuff    ( snx*nsx*npx*sny*nsy*npy )  
60        _RL     globmsk  ( snx,nsx,npx,sny,nsy,npy,nr )        _RL     globmsk  ( snx,nsx,npx,sny,nsy,npy,nr )
61        _RL     globfld3d( snx,nsx,npx,sny,nsy,npy,nr )        _RL     globfld3d( snx,nsx,npx,sny,nsy,npy,nr )
62  #ifdef CTRL_PACK_PRECISE  #ifdef CTRL_PACK_PRECISE
63        _RL   weightfld3d( snx,nsx,npx,sny,nsy,npy,nr )        _RL   weightfld3d( snx,nsx,npx,sny,nsy,npy,nr )
64  #endif  #endif
65          real*4 cbuff      ( snx*nsx*npx*sny*nsy*npy )
66          real*4 globfldtmp2( snx,nsx,npx,sny,nsy,npy )
67          real*4 globfldtmp3( snx,nsx,npx,sny,nsy,npy )
68    
69        character*(80) weightname        character*(80) weightname
70    
71          _RL delZnorm
72          integer reclen, irectrue
73          integer cunit2, cunit3
74          character*(80) cfile2, cfile3
75    
76  c     == external ==  c     == external ==
77    
78        integer  ilnblnk        integer  ilnblnk
# Line 85  c     == external == Line 80  c     == external ==
80    
81  c     == end of interface ==  c     == end of interface ==
82    
 #ifndef ALLOW_ECCO_OPTIMIZATION  
       optimcycle = 0  
 #endif  
   
83        jtlo = 1        jtlo = 1
84        jthi = nsy        jthi = nsy
85        itlo = 1        itlo = 1
# Line 98  c     == end of interface == Line 89  c     == end of interface ==
89        imin = 1        imin = 1
90        imax = snx        imax = snx
91    
92    #ifdef CTRL_DELZNORM
93          delZnorm = 0.
94          do k = 1, Nr
95             delZnorm = delZnorm + delR(k)/FLOAT(Nr)
96          enddo
97    #endif
98    
99  c     Initialise temporary file  c     Initialise temporary file
100        do k = 1,nr        do k = 1,nr
101           do jp = 1,nPy           do jp = 1,nPy
# Line 106  c     Initialise temporary file Line 104  c     Initialise temporary file
104                    do ip = 1,nPx                    do ip = 1,nPx
105                       do bi = itlo,ithi                       do bi = itlo,ithi
106                          do i = imin,imax                          do i = imin,imax
107                             globfld3d(i,bi,ip,j,bj,jp,k) = 0. _d 0                             globfld3d  (i,bi,ip,j,bj,jp,k) = 0. _d 0
108                             globmsk  (i,bi,ip,j,bj,jp,k) = 0. _d 0                             globmsk    (i,bi,ip,j,bj,jp,k) = 0. _d 0
109                               globfldtmp2(i,bi,ip,j,bj,jp)   = 0.
110                               globfldtmp3(i,bi,ip,j,bj,jp)   = 0.
111                          enddo                          enddo
112                       enddo                       enddo
113                    enddo                    enddo
# Line 119  c     Initialise temporary file Line 119  c     Initialise temporary file
119  c--   Only the master thread will do I/O.  c--   Only the master thread will do I/O.
120        _BEGIN_MASTER( mythid )        _BEGIN_MASTER( mythid )
121    
122          if ( doPackDiag ) then
123             write(cfile2(1:80),'(80a)') ' '
124             write(cfile3(1:80),'(80a)') ' '
125             if ( lxxadxx ) then
126                write(cfile2(1:80),'(a,I2.2,a,I4.4,a)')
127         &           'diag_pack_nonout_ctrl_',
128         &           ivartype, '_', optimcycle, '.bin'
129                write(cfile3(1:80),'(a,I2.2,a,I4.4,a)')
130         &           'diag_pack_dimout_ctrl_',
131         &           ivartype, '_', optimcycle, '.bin'
132             else
133                write(cfile2(1:80),'(a,I2.2,a,I4.4,a)')
134         &           'diag_pack_nonout_grad_',
135         &           ivartype, '_', optimcycle, '.bin'
136                write(cfile3(1:80),'(a,I2.2,a,I4.4,a)')
137         &           'diag_pack_dimout_grad_',
138         &           ivartype, '_', optimcycle, '.bin'
139             endif
140    
141             reclen = FLOAT(snx*nsx*npx*sny*nsy*npy*4)
142             call mdsfindunit( cunit2, mythid )
143             open( cunit2, file=cfile2, status='unknown',
144         &        access='direct', recl=reclen )
145             call mdsfindunit( cunit3, mythid )
146             open( cunit3, file=cfile3, status='unknown',
147         &        access='direct', recl=reclen )
148          endif
149    
150  #ifdef CTRL_PACK_PRECISE  #ifdef CTRL_PACK_PRECISE
151        il=ilnblnk( weighttype)        il=ilnblnk( weighttype)
152        write(weightname(1:80),'(80a)') ' '        write(weightname(1:80),'(80a)') ' '
# Line 138  c--   Only the master thread will do I/O Line 166  c--   Only the master thread will do I/O
166           call MDSREADFIELD_3D_GL( fname, ctrlprec, 'RL',           call MDSREADFIELD_3D_GL( fname, ctrlprec, 'RL',
167       &        Nr, globfld3d, irec, mythid)       &        Nr, globfld3d, irec, mythid)
168    
169    #ifndef ALLOW_ADMTLM
170           write(cunit) ncvarindex(ivartype)           write(cunit) ncvarindex(ivartype)
171           write(cunit) 1           write(cunit) 1
172           write(cunit) 1           write(cunit) 1
173    #endif
174           do k = 1, nr           do k = 1, nr
175             irectrue = (irec-1)*nr + k
176                if ( doZscalePack ) then
177                   delZnorm = (delR(1)/delR(k))**delZexp
178                else
179                   delZnorm = 1. _d 0
180                endif
181              cbuffindex = 0              cbuffindex = 0
182              do jp = 1,nPy              do jp = 1,nPy
183               do bj = jtlo,jthi               do bj = jtlo,jthi
# Line 149  c--   Only the master thread will do I/O Line 185  c--   Only the master thread will do I/O
185                 do ip = 1,nPx                 do ip = 1,nPx
186                  do bi = itlo,ithi                  do bi = itlo,ithi
187                   do i = imin,imax                   do i = imin,imax
188                    if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then                    if (globmsk(i,bi,ip,j,bj,jp,k) .ne. 0. ) then
189                       cbuffindex = cbuffindex + 1                       cbuffindex = cbuffindex + 1
190    cph(
191                         globfldtmp3(i,bi,ip,j,bj,jp) =
192         &                    globfld3d(i,bi,ip,j,bj,jp,k)
193    cph)
194  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO
195                       if (lxxadxx) then                       if (lxxadxx) then
196                          cbuff(cbuffindex) =                          cbuff(cbuffindex) = delZnorm
197       &                       globfld3d(i,bi,ip,j,bj,jp,k) *       &                       * globfld3d(i,bi,ip,j,bj,jp,k)
198  # ifdef CTRL_PACK_PRECISE  # ifdef CTRL_PACK_PRECISE
199       &                       sqrt(weightfld3d(i,bi,ip,j,bj,jp,k))       &                       * sqrt(weightfld3d(i,bi,ip,j,bj,jp,k))
200  # else  # else
201       &                       sqrt(weightfld(k,bi,bj))       &                       * sqrt(weightfld(k,bi,bj))
202  # endif  # endif
203                       else                       else
204                          cbuff(cbuffindex) =                          cbuff(cbuffindex) = delZnorm
205       &                       globfld3d(i,bi,ip,j,bj,jp,k) /       &                       * globfld3d(i,bi,ip,j,bj,jp,k)
206  # ifdef CTRL_PACK_PRECISE  # ifdef CTRL_PACK_PRECISE
207       &                       sqrt(weightfld3d(i,bi,ip,j,bj,jp,k))       &                       / sqrt(weightfld3d(i,bi,ip,j,bj,jp,k))
208  # else  # else
209       &                       sqrt(weightfld(k,bi,bj))       &                       / sqrt(weightfld(k,bi,bj))
210  # endif  # endif
211                       endif                       endif
212    cph(
213                         globfldtmp2(i,bi,ip,j,bj,jp) = cbuff(cbuffindex)
214    cph)
215  #else /* ALLOW_NONDIMENSIONAL_CONTROL_IO undef */  #else /* ALLOW_NONDIMENSIONAL_CONTROL_IO undef */
216                       cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)                       cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)
217  #endif /* ALLOW_NONDIMENSIONAL_CONTROL_IO */  #endif /* ALLOW_NONDIMENSIONAL_CONTROL_IO */
218    #ifdef ALLOW_ADMTLM
219                         nveccount = nveccount + 1
220                         phtmpadmtlm(nveccount) = cbuff(cbuffindex)
221    #endif
222                    endif                    endif
223                   enddo                   enddo
224                  enddo                  enddo
# Line 181  c--   Only the master thread will do I/O Line 228  c--   Only the master thread will do I/O
228              enddo              enddo
229  c           --> check cbuffindex.  c           --> check cbuffindex.
230              if ( cbuffindex .gt. 0) then              if ( cbuffindex .gt. 0) then
231    #ifndef ALLOW_ADMTLM
232                 write(cunit) cbuffindex                 write(cunit) cbuffindex
233                 write(cunit) k                 write(cunit) k
234    cph#endif
235                 write(cunit) (cbuff(ii), ii=1,cbuffindex)                 write(cunit) (cbuff(ii), ii=1,cbuffindex)
236    #endif
237                endif
238    c
239                if ( doPackDiag ) then
240                   write(cunit2,rec=irectrue) globfldtmp2
241                   write(cunit3,rec=irectrue) globfldtmp3
242              endif              endif
243    c
244           enddo           enddo
245  c  c
246  c     -- end of irec loop --  c     -- end of irec loop --
247        enddo        enddo
248    
249          if ( doPackDiag ) then
250             close ( cunit2 )
251             close ( cunit3 )
252          endif
253    
254        _END_MASTER( mythid )        _END_MASTER( mythid )
255    
256        return        return
Legend:
Removed from v.1.6  
changed lines
  Added in v.1.15
  ViewVC Help
Powered by ViewVC 1.1.22