/[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.14 by heimbach, Fri Jan 27 05:41:51 2006 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
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        integer nwetglobal(nr)        integer nwetglobal(nr)
# 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          _RL delZnorm
73          integer reclen, irectrue
74          integer cunit2, cunit3
75          character*(80) cfile2, cfile3
76    
77  c     == external ==  c     == external ==
78    
79        integer  ilnblnk        integer  ilnblnk
# Line 82  cc     == end of interface == Line 90  cc     == end of interface ==
90        imin = 1        imin = 1
91        imax = snx        imax = snx
92    
93    #ifdef CTRL_DELZNORM
94          delZnorm = 0.
95          do k = 1, Nr
96             delZnorm = delZnorm + delR(k)/FLOAT(Nr)
97          enddo
98    #endif
99    
100  c     Initialise temporary file  c     Initialise temporary file
101        do k = 1,nr        do k = 1,nr
102           do jp = 1,nPy           do jp = 1,nPy
# Line 90  c     Initialise temporary file Line 105  c     Initialise temporary file
105                    do ip = 1,nPx                    do ip = 1,nPx
106                       do bi = itlo,ithi                       do bi = itlo,ithi
107                          do i = imin,imax                          do i = imin,imax
108                             globfld3d(i,bi,ip,j,bj,jp,k) = 0. _d 0                             globfld3d  (i,bi,ip,j,bj,jp,k) = 0. _d 0
109                             globmsk  (i,bi,ip,j,bj,jp,k) = 0. _d 0                             globmsk    (i,bi,ip,j,bj,jp,k) = 0. _d 0
110                               globfldtmp2(i,bi,ip,j,bj,jp)   = 0.
111                               globfldtmp3(i,bi,ip,j,bj,jp)   = 0.
112                          enddo                          enddo
113                       enddo                       enddo
114                    enddo                    enddo
# Line 103  c     Initialise temporary file Line 120  c     Initialise temporary file
120  c--   Only the master thread will do I/O.  c--   Only the master thread will do I/O.
121        _BEGIN_MASTER( mythid )        _BEGIN_MASTER( mythid )
122    
123    #ifdef CTRL_DELZNORM
124          do k = 1, nr
125             print *, 'ph-delznorm ', k, delZnorm, delR(k)
126             print *, 'ph-weight   ', weightfld(k,1,1)
127          enddo
128    #endif
129    
130          if ( doPackDiag ) then
131             write(cfile2(1:80),'(80a)') ' '
132             write(cfile3(1:80),'(80a)') ' '
133             if ( lxxadxx ) then
134                write(cfile2(1:80),'(a,I2.2,a,I4.4,a)')
135         &           'diag_unpack_nondim_ctrl_',
136         &           ivartype, '_', optimcycle, '.bin'
137                write(cfile3(1:80),'(a,I2.2,a,I4.4,a)')
138         &           'diag_unpack_dimens_ctrl_',
139         &           ivartype, '_', optimcycle, '.bin'
140             else
141                write(cfile2(1:80),'(a,I2.2,a,I4.4,a)')
142         &           'diag_unpack_nondim_grad_',
143         &           ivartype, '_', optimcycle, '.bin'
144                write(cfile3(1:80),'(a,I2.2,a,I4.4,a)')
145         &           'diag_unpack_dimens_grad_',
146         &           ivartype, '_', optimcycle, '.bin'
147             endif
148    
149             reclen = FLOAT(snx*nsx*npx*sny*nsy*npy*4)
150             call mdsfindunit( cunit2, mythid )
151             open( cunit2, file=cfile2, status='unknown',
152         &        access='direct', recl=reclen )
153             call mdsfindunit( cunit3, mythid )
154             open( cunit3, file=cfile3, status='unknown',
155         &        access='direct', recl=reclen )
156          endif
157    
158  #ifdef CTRL_UNPACK_PRECISE  #ifdef CTRL_UNPACK_PRECISE
159        il=ilnblnk( weighttype)        il=ilnblnk( weighttype)
160        write(weightname(1:80),'(80a)') ' '        write(weightname(1:80),'(80a)') ' '
# Line 118  c--   Only the master thread will do I/O Line 170  c--   Only the master thread will do I/O
170       &     Nr, globmsk, 1, mythid)       &     Nr, globmsk, 1, mythid)
171    
172        do irec = 1, ncvarrecs(ivartype)        do irec = 1, ncvarrecs(ivartype)
173    #ifndef ALLOW_ADMTLM
174           read(cunit) filencvarindex(ivartype)           read(cunit) filencvarindex(ivartype)
175           if (filencvarindex(ivartype) .NE. ncvarindex(ivartype))           if (filencvarindex(ivartype) .NE. ncvarindex(ivartype))
176       &        then       &        then
# Line 127  c--   Only the master thread will do I/O Line 180  c--   Only the master thread will do I/O
180           endif           endif
181           read(cunit) filej           read(cunit) filej
182           read(cunit) filei           read(cunit) filei
183    #endif /* ALLOW_ADMTLM */
184           do k = 1, Nr           do k = 1, Nr
185             irectrue = (irec-1)*nr + k
186                if ( doZscaleUnpack ) then
187    cph               delZnorm = SQRT(delR(1)/delR(k))
188                   delZnorm = delR(1)/delR(k)
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 142  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    #endif /* ALLOW_ADMTLM */
208                 read(cunit) (cbuff(ii), ii=1,cbuffindex)                 read(cunit) (cbuff(ii), ii=1,cbuffindex)
209              endif              endif
210    c
211              cbuffindex = 0              cbuffindex = 0
212              do jp = 1,nPy              do jp = 1,nPy
213               do bj = jtlo,jthi               do bj = jtlo,jthi
# Line 154  c--   Only the master thread will do I/O Line 218  c--   Only the master thread will do I/O
218                    if ( globmsk(i,bi,ip,j,bj,jp,k) .ne. 0. ) then                    if ( globmsk(i,bi,ip,j,bj,jp,k) .ne. 0. ) then
219                       cbuffindex = cbuffindex + 1                       cbuffindex = cbuffindex + 1
220                       globfld3d(i,bi,ip,j,bj,jp,k) = cbuff(cbuffindex)                       globfld3d(i,bi,ip,j,bj,jp,k) = cbuff(cbuffindex)
221  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  cph(
222                         globfldtmp2(i,bi,ip,j,bj,jp) = cbuff(cbuffindex)
223    cph)
224    #ifdef ALLOW_ADMTLM
225                         nveccount = nveccount + 1
226                       globfld3d(i,bi,ip,j,bj,jp,k) =                       globfld3d(i,bi,ip,j,bj,jp,k) =
227       &                    globfld3d(i,bi,ip,j,bj,jp,k)/       &                 phtmpadmtlm(nveccount)
228    cph(
229                         globfldtmp2(i,bi,ip,j,bj,jp) =
230         &                 phtmpadmtlm(nveccount)
231    cph)
232    #endif
233    #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO
234                         if ( lxxadxx ) then
235                            globfld3d(i,bi,ip,j,bj,jp,k) = delZnorm
236         &                       * globfld3d(i,bi,ip,j,bj,jp,k)
237    # ifdef CTRL_UNPACK_PRECISE
238         &                       / sqrt(weightfld3d(i,bi,ip,j,bj,jp,k))
239    # else
240         &                       / sqrt(weightfld(k,bi,bj))
241    # endif
242                         else
243                            globfld3d(i,bi,ip,j,bj,jp,k) = delZnorm
244         &                       * globfld3d(i,bi,ip,j,bj,jp,k)
245  # ifdef CTRL_UNPACK_PRECISE  # ifdef CTRL_UNPACK_PRECISE
246       &                    sqrt(weightfld3d(i,bi,ip,j,bj,jp,k))       &                       * sqrt(weightfld3d(i,bi,ip,j,bj,jp,k))
247  # else  # else
248       &                    sqrt(weightfld(k,bi,bj))       &                       * sqrt(weightfld(k,bi,bj))
249  # endif  # endif
250                         endif
251  #endif /* ALLOW_NONDIMENSIONAL_CONTROL_IO */  #endif /* ALLOW_NONDIMENSIONAL_CONTROL_IO */
252                    else                    else
253                       globfld3d(i,bi,ip,j,bj,jp,k) = 0. _d 0                       globfld3d(i,bi,ip,j,bj,jp,k) = 0. _d 0
254                    endif                    endif
255    cph(
256                      globfldtmp3(i,bi,ip,j,bj,jp) =
257         &                 globfld3d(i,bi,ip,j,bj,jp,k)
258    cph)
259                   enddo                   enddo
260                  enddo                  enddo
261                 enddo                 enddo
# Line 173  c--   Only the master thread will do I/O Line 263  c--   Only the master thread will do I/O
263               enddo               enddo
264              enddo              enddo
265  c  c
266                if ( doPackDiag ) then
267                   write(cunit2,rec=irectrue) globfldtmp2
268                   write(cunit3,rec=irectrue) globfldtmp3
269                endif
270    c
271           enddo           enddo
272                            
273           call MDSWRITEFIELD_3D_GL( fname, ctrlprec, 'RL',           call MDSWRITEFIELD_3D_GL( fname, ctrlprec, 'RL',
# Line 181  c Line 276  c
276    
277        enddo        enddo
278    
279          if ( doPackDiag ) then
280             close ( cunit2 )
281             close ( cunit3 )
282          endif
283    
284        _END_MASTER( mythid )        _END_MASTER( mythid )
285    
286        return        return
Legend:
Removed from v.1.8  
changed lines
  Added in v.1.14
  ViewVC Help
Powered by ViewVC 1.1.22