/[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.1 by heimbach, Tue Feb 5 20:23:58 2002 UTC revision 1.2 by heimbach, Sat Jul 13 02:47:32 2002 UTC
# Line 0  Line 1 
1    
2    #include "CTRL_CPPOPTIONS.h"
3    
4    
5          subroutine ctrl_set_unpack_xyz(
6         &     cunit, ivartype, fname, masktype,
7         &     weightfld, nwetglobal, mythid)
8    
9    c     ==================================================================
10    c     SUBROUTINE ctrl_set_unpack_xyz
11    c     ==================================================================
12    c
13    c     o Unpack the control vector such that the land points are filled
14    c       in.
15    c
16    c     ==================================================================
17    
18          implicit none
19    
20    c     == global variables ==
21    
22    #include "EEPARAMS.h"
23    #include "SIZE.h"
24    #include "PARAMS.h"
25    #include "GRID.h"
26    
27    #include "ctrl.h"
28    #include "cost.h"
29    
30    #ifdef ALLOW_ECCO_OPTIMIZATION
31    #include "optim.h"
32    #endif
33    
34    c     == routine arguments ==
35    
36          integer cunit
37          integer ivartype
38          character*( 80)   fname
39          character*  (5) masktype
40          _RL     weightfld( nr,nsx,nsy )
41          integer nwetglobal(nr)
42          integer mythid
43    
44    c     == local variables ==
45    
46    #ifndef ALLOW_ECCO_OPTIMIZATION
47          integer optimcycle
48    #endif
49    
50          integer bi,bj
51          integer ip,jp
52          integer i,j,k
53          integer ii
54          integer il
55          integer irec
56          integer itlo,ithi
57          integer jtlo,jthi
58          integer jmin,jmax
59          integer imin,imax
60    
61          integer cbuffindex
62    
63          _RL     cbuff    ( snx*nsx*npx*sny*nsy*npy )
64          _RL     globmsk  ( snx,nsx,npx,sny,nsy,npy,nr )
65          _RL     globfld3d( snx,nsx,npx,sny,nsy,npy,nr )
66    
67          character*(128)   cfile
68    
69          integer        filenvartype
70          integer        filenvarlength
71          character*(10) fileExpId
72          integer        fileOptimCycle
73          integer        filencbuffindex
74          _RL            fileDummy
75          integer        fileIg
76          integer        fileJg
77          integer        fileI
78          integer        fileJ
79          integer        filensx
80          integer        filensy
81          integer        filek
82          integer        filencvarindex(maxcvars)
83          integer        filencvarrecs(maxcvars)
84          integer        filencvarxmax(maxcvars)
85          integer        filencvarymax(maxcvars)
86          integer        filencvarnrmax(maxcvars)
87          character*( 1) filencvargrd(maxcvars)
88    
89    c     == external ==
90    
91          integer  ilnblnk
92          external ilnblnk
93    
94    cc     == end of interface ==
95    
96          jtlo = 1
97          jthi = nsy
98          itlo = 1
99          ithi = nsx
100          jmin = 1
101          jmax = sny
102          imin = 1
103          imax = snx
104    
105    c     Initialise temporary file
106          do k = 1,nr
107             do jp = 1,nPy
108                do bj = jtlo,jthi
109                   do j = jmin,jmax
110                      do ip = 1,nPx
111                         do bi = itlo,ithi
112                            do i = imin,imax
113                               globfld3d(i,bi,ip,j,bj,jp,k) = 0. _d 0
114                               globmsk  (i,bi,ip,j,bj,jp,k) = 0. _d 0
115                            enddo
116                         enddo
117                      enddo
118                   enddo
119                enddo
120             enddo
121          enddo
122    
123    #ifndef ALLOW_ECCO_OPTIMIZATION
124          optimcycle = 0
125    #endif
126    
127    c--   Only the master thread will do I/O.
128          _BEGIN_MASTER( mythid )
129    
130          call MDSREADFIELD_3D_GL(
131         &     masktype, ctrlprec, 'RL',
132         &     Nr, globmsk, 1, mythid)
133    
134          do irec = 1, ncvarrecs(ivartype)
135             read(cunit) filencvarindex(ivartype)
136             if (filencvarindex(ivartype) .NE. ncvarindex(ivartype))
137         &        then
138                print *, 'ctrl_set_unpack_xyz:WARNING: wrong ncvarindex ',
139         &           filencvarindex(ivartype), ncvarindex(ivartype)
140                STOP 'in S/R ctrl_unpack'
141             endif
142             read(cunit) filej
143             read(cunit) filei
144             do k = 1, Nr
145                cbuffindex = nwetglobal(k)
146                if ( cbuffindex .gt. 0 ) then
147                   read(cunit) filencbuffindex
148                   if (filencbuffindex .NE. cbuffindex) then
149                      print *, 'WARNING: wrong cbuffindex ',
150         &                 filencbuffindex, cbuffindex
151                      STOP 'in S/R ctrl_unpack'
152                   endif
153                   read(cunit) filek
154                   if (filek .NE. k) then
155                      print *, 'WARNING: wrong k ',
156         &                 filek, k
157                      STOP 'in S/R ctrl_unpack'
158                   endif
159                   read(cunit) (cbuff(ii), ii=1,cbuffindex)
160                endif
161                cbuffindex = 0
162                do jp = 1,nPy
163                 do bj = jtlo,jthi
164                  do j = jmin,jmax
165                   do ip = 1,nPx
166                    do bi = itlo,ithi
167                     do i = imin,imax
168                      if ( globmsk(i,bi,ip,j,bj,jp,k) .ne. 0. ) then
169                         cbuffindex = cbuffindex + 1
170                         globfld3d(i,bi,ip,j,bj,jp,k) = cbuff(cbuffindex)
171    #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO
172                         globfld3d(i,bi,ip,j,bj,jp,k) =
173         &                    globfld3d(i,bi,ip,j,bj,jp,k)/
174         &                    sqrt(weightfld(k,bi,bj))
175    #endif
176                      else
177                         globfld3d(i,bi,ip,j,bj,jp,k) = 0. _d 0
178                      endif
179                     enddo
180                    enddo
181                   enddo
182                  enddo
183                 enddo
184                enddo
185    c
186             enddo
187                
188             call MDSWRITEFIELD_3D_GL( fname, ctrlprec, 'RL',
189         &                             Nr, globfld3d,
190         &                             irec,  optimcycle, mythid)
191    
192          enddo
193    
194          _END_MASTER( mythid )
195    
196          return
197          end
198    
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2
  ViewVC Help
Powered by ViewVC 1.1.22