/[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.8 by heimbach, Tue Nov 16 05:42:12 2004 UTC revision 1.9 by heimbach, Tue Jan 4 22:02:31 2005 UTC
# Line 57  c     == local variables == Line 57  c     == local variables ==
57    
58        integer cbuffindex        integer cbuffindex
59    
       real*4     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    #ifdef CTRL_DELZNORM
72          _RL delZnorm
73    #endif
74          integer reclen, irectrue
75          integer cunit2, cunit3
76          character*(80) cfile2, cfile3
77    
78  c     == external ==  c     == external ==
79    
80        integer  ilnblnk        integer  ilnblnk
# Line 82  c     == end of interface == Line 91  c     == 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 90  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 103  c     Initialise temporary file Line 121  c     Initialise temporary file
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          if ( doPackDiag ) then
125             write(cfile2(1:80),'(80a)') ' '
126             write(cfile3(1:80),'(80a)') ' '
127             if ( lxxadxx ) then
128                write(cfile2(1:80),'(a,I2.2,a,I4.4,a)')
129         &           'diag_pack_nonout_ctrl_',
130         &           ivartype, '_', optimcycle, '.bin'
131                write(cfile3(1:80),'(a,I2.2,a,I4.4,a)')
132         &           'diag_pack_dimout_ctrl_',
133         &           ivartype, '_', optimcycle, '.bin'
134             else
135                write(cfile2(1:80),'(a,I2.2,a,I4.4,a)')
136         &           'diag_pack_nonout_grad_',
137         &           ivartype, '_', optimcycle, '.bin'
138                write(cfile3(1:80),'(a,I2.2,a,I4.4,a)')
139         &           'diag_pack_dimout_grad_',
140         &           ivartype, '_', optimcycle, '.bin'
141             endif
142    
143             reclen = FLOAT(snx*nsx*npx*sny*nsy*npy*4)
144             call mdsfindunit( cunit2, mythid )
145             open( cunit2, file=cfile2, status='unknown',
146         &        access='direct', recl=reclen )
147             call mdsfindunit( cunit3, mythid )
148             open( cunit3, file=cfile3, status='unknown',
149         &        access='direct', recl=reclen )
150          endif
151    
152  #ifdef CTRL_PACK_PRECISE  #ifdef CTRL_PACK_PRECISE
153        il=ilnblnk( weighttype)        il=ilnblnk( weighttype)
154        write(weightname(1:80),'(80a)') ' '        write(weightname(1:80),'(80a)') ' '
# Line 126  c--   Only the master thread will do I/O Line 172  c--   Only the master thread will do I/O
172           write(cunit) 1           write(cunit) 1
173           write(cunit) 1           write(cunit) 1
174           do k = 1, nr           do k = 1, nr
175             irectrue = (irec-1)*nr + k
176              cbuffindex = 0              cbuffindex = 0
177              do jp = 1,nPy              do jp = 1,nPy
178               do bj = jtlo,jthi               do bj = jtlo,jthi
# Line 133  c--   Only the master thread will do I/O Line 180  c--   Only the master thread will do I/O
180                 do ip = 1,nPx                 do ip = 1,nPx
181                  do bi = itlo,ithi                  do bi = itlo,ithi
182                   do i = imin,imax                   do i = imin,imax
183                    if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then                    if (globmsk(i,bi,ip,j,bj,jp,k) .ne. 0. ) then
184                       cbuffindex = cbuffindex + 1                       cbuffindex = cbuffindex + 1
185    cph(
186                         globfldtmp3(i,bi,ip,j,bj,jp) =
187         &                    globfld3d(i,bi,ip,j,bj,jp,k)
188    cph)
189  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO
190                       if (lxxadxx) then                       if (lxxadxx) then
191                          cbuff(cbuffindex) =                          cbuff(cbuffindex) =
192       &                       globfld3d(i,bi,ip,j,bj,jp,k) *       &                       globfld3d(i,bi,ip,j,bj,jp,k)
193  # ifdef CTRL_PACK_PRECISE  # ifdef CTRL_PACK_PRECISE
194       &                       sqrt(weightfld3d(i,bi,ip,j,bj,jp,k))       &                       * sqrt(weightfld3d(i,bi,ip,j,bj,jp,k))
195  # else  # else
196       &                       sqrt(weightfld(k,bi,bj))       &                       * sqrt(weightfld(k,bi,bj))
197  # endif  # endif
198                       else                       else
199                          cbuff(cbuffindex) =                          cbuff(cbuffindex) =
200       &                       globfld3d(i,bi,ip,j,bj,jp,k) /       &                       globfld3d(i,bi,ip,j,bj,jp,k)
201  # ifdef CTRL_PACK_PRECISE  # ifdef CTRL_PACK_PRECISE
202       &                       sqrt(weightfld3d(i,bi,ip,j,bj,jp,k))       &                       / sqrt(weightfld3d(i,bi,ip,j,bj,jp,k))
203  # else  # else
204       &                       sqrt(weightfld(k,bi,bj))       &                       / sqrt(weightfld(k,bi,bj))
205  # endif  # endif
206                       endif                       endif
207    cph(
208                         globfldtmp2(i,bi,ip,j,bj,jp) = cbuff(cbuffindex)
209    cph)
210  #else /* ALLOW_NONDIMENSIONAL_CONTROL_IO undef */  #else /* ALLOW_NONDIMENSIONAL_CONTROL_IO undef */
211                       cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)                       cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)
212  #endif /* ALLOW_NONDIMENSIONAL_CONTROL_IO */  #endif /* ALLOW_NONDIMENSIONAL_CONTROL_IO */
# Line 169  c           --> check cbuffindex. Line 223  c           --> check cbuffindex.
223                 write(cunit) k                 write(cunit) k
224                 write(cunit) (cbuff(ii), ii=1,cbuffindex)                 write(cunit) (cbuff(ii), ii=1,cbuffindex)
225              endif              endif
226    c
227                if ( doPackDiag ) then
228                   write(cunit2,rec=irectrue) globfldtmp2
229                   write(cunit3,rec=irectrue) globfldtmp3
230                endif
231    c
232           enddo           enddo
233  c  c
234  c     -- end of irec loop --  c     -- end of irec loop --
235        enddo        enddo
236    
237          if ( doPackDiag ) then
238             close ( cunit2 )
239             close ( cunit3 )
240          endif
241    
242        _END_MASTER( mythid )        _END_MASTER( mythid )
243    
244        return        return
Legend:
Removed from v.1.8  
changed lines
  Added in v.1.9
  ViewVC Help
Powered by ViewVC 1.1.22