/[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.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 2  Line 2 
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, weighttype,       &     lxxadxx, cunit, ivartype, fname, masktype, weighttype,
6       &     weightfld, nwetglobal, mythid)       &     weightfld, nwetglobal, mythid)
7    
8  c     ==================================================================  c     ==================================================================
# Line 32  c     == global variables == Line 32  c     == global variables ==
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
# Line 56  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_UNPACK_PRECISE  #ifdef CTRL_UNPACK_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*(128)   cfile        character*(128)   cfile
70        character*(80) weightname        character*(80) weightname
71    
72    #ifdef CTRL_DELZNORM
73          _RL delZnorm
74    #endif
75          integer reclen, irectrue
76          integer cunit2, cunit3
77          character*(80) cfile2, cfile3
78    
79  c     == external ==  c     == external ==
80    
81        integer  ilnblnk        integer  ilnblnk
# Line 82  cc     == end of interface == Line 92  cc     == end of interface ==
92        imin = 1        imin = 1
93        imax = snx        imax = snx
94    
95    #ifdef CTRL_DELZNORM
96          delZnorm = 0.
97          do k = 1, Nr
98             delZnorm = delZnorm + delR(k)/FLOAT(Nr)
99          enddo
100    #endif
101    
102  c     Initialise temporary file  c     Initialise temporary file
103        do k = 1,nr        do k = 1,nr
104           do jp = 1,nPy           do jp = 1,nPy
# Line 90  c     Initialise temporary file Line 107  c     Initialise temporary file
107                    do ip = 1,nPx                    do ip = 1,nPx
108                       do bi = itlo,ithi                       do bi = itlo,ithi
109                          do i = imin,imax                          do i = imin,imax
110                             globfld3d(i,bi,ip,j,bj,jp,k) = 0. _d 0                             globfld3d  (i,bi,ip,j,bj,jp,k) = 0. _d 0
111                             globmsk  (i,bi,ip,j,bj,jp,k) = 0. _d 0                             globmsk    (i,bi,ip,j,bj,jp,k) = 0. _d 0
112                               globfldtmp2(i,bi,ip,j,bj,jp)   = 0.
113                               globfldtmp3(i,bi,ip,j,bj,jp)   = 0.
114                          enddo                          enddo
115                       enddo                       enddo
116                    enddo                    enddo
# Line 103  c     Initialise temporary file Line 122  c     Initialise temporary file
122  c--   Only the master thread will do I/O.  c--   Only the master thread will do I/O.
123        _BEGIN_MASTER( mythid )        _BEGIN_MASTER( mythid )
124    
125    #ifdef CTRL_DELZNORM
126          do k = 1, nr
127             print *, 'ph-delznorm ', k, delZnorm, delR(k)
128             print *, 'ph-weight   ', weightfld(k,1,1)
129          enddo
130    #endif
131    
132          if ( doPackDiag ) then
133             write(cfile2(1:80),'(80a)') ' '
134             write(cfile3(1:80),'(80a)') ' '
135             if ( lxxadxx ) then
136                write(cfile2(1:80),'(a,I2.2,a,I4.4,a)')
137         &           'diag_unpack_nondim_ctrl_',
138         &           ivartype, '_', optimcycle, '.bin'
139                write(cfile3(1:80),'(a,I2.2,a,I4.4,a)')
140         &           'diag_unpack_dimens_ctrl_',
141         &           ivartype, '_', optimcycle, '.bin'
142             else
143                write(cfile2(1:80),'(a,I2.2,a,I4.4,a)')
144         &           'diag_unpack_nondim_grad_',
145         &           ivartype, '_', optimcycle, '.bin'
146                write(cfile3(1:80),'(a,I2.2,a,I4.4,a)')
147         &           'diag_unpack_dimens_grad_',
148         &           ivartype, '_', optimcycle, '.bin'
149             endif
150    
151             reclen = FLOAT(snx*nsx*npx*sny*nsy*npy*4)
152             call mdsfindunit( cunit2, mythid )
153             open( cunit2, file=cfile2, status='new',
154         &        access='direct', recl=reclen )
155             call mdsfindunit( cunit3, mythid )
156             open( cunit3, file=cfile3, status='new',
157         &        access='direct', recl=reclen )
158          endif
159    
160  #ifdef CTRL_UNPACK_PRECISE  #ifdef CTRL_UNPACK_PRECISE
161        il=ilnblnk( weighttype)        il=ilnblnk( weighttype)
162        write(weightname(1:80),'(80a)') ' '        write(weightname(1:80),'(80a)') ' '
# Line 128  c--   Only the master thread will do I/O Line 182  c--   Only the master thread will do I/O
182           read(cunit) filej           read(cunit) filej
183           read(cunit) filei           read(cunit) filei
184           do k = 1, Nr           do k = 1, Nr
185             irectrue = (irec-1)*nr + k
186              cbuffindex = nwetglobal(k)              cbuffindex = nwetglobal(k)
187              if ( cbuffindex .gt. 0 ) then              if ( cbuffindex .gt. 0 ) then
188                 read(cunit) filencbuffindex                 read(cunit) filencbuffindex
# Line 154  c--   Only the master thread will do I/O Line 209  c--   Only the master thread will do I/O
209                    if ( globmsk(i,bi,ip,j,bj,jp,k) .ne. 0. ) then                    if ( globmsk(i,bi,ip,j,bj,jp,k) .ne. 0. ) then
210                       cbuffindex = cbuffindex + 1                       cbuffindex = cbuffindex + 1
211                       globfld3d(i,bi,ip,j,bj,jp,k) = cbuff(cbuffindex)                       globfld3d(i,bi,ip,j,bj,jp,k) = cbuff(cbuffindex)
212    cph(
213                         globfldtmp2(i,bi,ip,j,bj,jp) = cbuff(cbuffindex)
214    cph)
215  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO
216                       globfld3d(i,bi,ip,j,bj,jp,k) =                       if ( lxxadxx ) then
217       &                    globfld3d(i,bi,ip,j,bj,jp,k)/                          globfld3d(i,bi,ip,j,bj,jp,k) =
218         &                       globfld3d(i,bi,ip,j,bj,jp,k)
219    # ifdef CTRL_UNPACK_PRECISE
220         &                    / sqrt(weightfld3d(i,bi,ip,j,bj,jp,k))
221    # else
222         &                    / sqrt(weightfld(k,bi,bj))
223    # endif
224                         else
225                            globfld3d(i,bi,ip,j,bj,jp,k) =
226         &                       globfld3d(i,bi,ip,j,bj,jp,k)
227  # ifdef CTRL_UNPACK_PRECISE  # ifdef CTRL_UNPACK_PRECISE
228       &                    sqrt(weightfld3d(i,bi,ip,j,bj,jp,k))       &                       * sqrt(weightfld3d(i,bi,ip,j,bj,jp,k))
229  # else  # else
230       &                    sqrt(weightfld(k,bi,bj))       &                       * sqrt(weightfld(k,bi,bj))
231  # endif  # endif
232                         endif
233  #endif /* ALLOW_NONDIMENSIONAL_CONTROL_IO */  #endif /* ALLOW_NONDIMENSIONAL_CONTROL_IO */
234                    else                    else
235                       globfld3d(i,bi,ip,j,bj,jp,k) = 0. _d 0                       globfld3d(i,bi,ip,j,bj,jp,k) = 0. _d 0
236                    endif                    endif
237    cph(
238                      globfldtmp3(i,bi,ip,j,bj,jp) =
239         &                 globfld3d(i,bi,ip,j,bj,jp,k)
240    cph)
241                   enddo                   enddo
242                  enddo                  enddo
243                 enddo                 enddo
# Line 173  c--   Only the master thread will do I/O Line 245  c--   Only the master thread will do I/O
245               enddo               enddo
246              enddo              enddo
247  c  c
248                if ( doPackDiag ) then
249                   write(cunit2,rec=irectrue) globfldtmp2
250                   write(cunit3,rec=irectrue) globfldtmp3
251                endif
252    c
253           enddo           enddo
254                            
255           call MDSWRITEFIELD_3D_GL( fname, ctrlprec, 'RL',           call MDSWRITEFIELD_3D_GL( fname, ctrlprec, 'RL',
# Line 181  c Line 258  c
258    
259        enddo        enddo
260    
261          if ( doPackDiag ) then
262             close ( cunit2 )
263             close ( cunit3 )
264          endif
265    
266        _END_MASTER( mythid )        _END_MASTER( mythid )
267    
268        return        return
Legend:
Removed from v.1.8  
changed lines
  Added in v.1.9
  ViewVC Help
Powered by ViewVC 1.1.22