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

Diff of /MITgcm/pkg/ctrl/ctrl_set_unpack_yz.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_yz(
6         &     cunit, ivartype, fname, masktype,
7         &     weightfld, nwetglobal, mythid)
8    
9    c     ==================================================================
10    c     SUBROUTINE ctrl_set_unpack_yz
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*  (9) masktype
40          _RL     weightfld( nr,nobcs )
41          integer nwetglobal(nr,nobcs)
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,iobcs
56          integer itlo,ithi
57          integer jtlo,jthi
58          integer jmin,jmax
59          integer imin,imax
60    
61          integer cbuffindex
62    
63          _RL     cbuff    ( nsx*npx*sny*nsy*npy )
64          _RL     globmskyz( nsx,npx,sny,nsy,npy,nr )
65          _RL     globfldyz( nsx,npx,sny,nsy,npy,nr )
66    
67          integer        filenvartype
68          integer        filenvarlength
69          character*(10) fileExpId
70          integer        fileOptimCycle
71          integer        filencbuffindex
72          _RL            fileDummy
73          integer        fileIg
74          integer        fileJg
75          integer        fileI
76          integer        fileJ
77          integer        filensx
78          integer        filensy
79          integer        filek
80          integer        filencvarindex(maxcvars)
81          integer        filencvarrecs(maxcvars)
82          integer        filencvarxmax(maxcvars)
83          integer        filencvarymax(maxcvars)
84          integer        filencvarnrmax(maxcvars)
85          character*( 1) filencvargrd(maxcvars)
86    cgg(
87          integer igg
88          _RL     gg
89    cgg)
90    
91    c     == external ==
92    
93          integer  ilnblnk
94          external ilnblnk
95    
96    cc     == end of interface ==
97    
98          jtlo = 1
99          jthi = nsy
100          itlo = 1
101          ithi = nsx
102          jmin = 1
103          jmax = sny
104          imin = 1
105          imax = snx
106    
107    c     Initialise temporary file
108          do k = 1,nr
109             do jp = 1,nPy
110                do bj = jtlo,jthi
111                   do j = jmin,jmax
112                      do ip = 1,nPx
113                         do bi = itlo,ithi
114                            globfldyz(bi,ip,j,bj,jp,k) = 0. _d 0
115                            globmskyz(bi,ip,j,bj,jp,k) = 0. _d 0
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          do irec = 1, ncvarrecs(ivartype)
131    cgg      do iobcs = 1, nobcs
132    cgg      Iobcs has already been included in the calculation
133    cgg      of ncvarrecs.
134    cgg      And now back-calculate what iobcs should be.
135              gg   = (irec-1)/nobcs
136              igg  = int(gg)
137              iobcs = irec - igg*nobcs
138    
139             call MDSREADFIELD_YZ_GL(
140         &        masktype, ctrlprec, 'RL',
141         &        Nr, globmskyz, iobcs, mythid)
142    
143             read(cunit) filencvarindex(ivartype)
144             if (filencvarindex(ivartype) .NE. ncvarindex(ivartype))
145         &        then
146                print *, 'ctrl_set_unpack_yz:WARNING: wrong ncvarindex ',
147         &           filencvarindex(ivartype), ncvarindex(ivartype)
148                STOP 'in S/R ctrl_unpack'
149             endif
150             read(cunit) filej
151             read(cunit) filei
152             do k = 1, Nr
153                cbuffindex = nwetglobal(k,iobcs)
154                if ( cbuffindex .gt. 0 ) then
155                   read(cunit) filencbuffindex
156                   if (filencbuffindex .NE. cbuffindex) then
157                      print *, 'WARNING: wrong cbuffindex ',
158         &                 filencbuffindex, cbuffindex
159                      STOP 'in S/R ctrl_unpack'
160                   endif
161                   read(cunit) filek
162                   if (filek .NE. k) then
163                      print *, 'WARNING: wrong k ',
164         &                 filek, k
165                      STOP 'in S/R ctrl_unpack'
166                   endif
167                   read(cunit) (cbuff(ii), ii=1,cbuffindex)
168                endif
169                cbuffindex = 0
170                do jp = 1,nPy
171                 do bj = jtlo,jthi
172                  do j = jmin,jmax
173                   do ip = 1,nPx
174                    do bi = itlo,ithi
175                      if ( globmskyz(bi,ip,j,bj,jp,k) .ne. 0. ) then
176                         cbuffindex = cbuffindex + 1
177                         globfldyz(bi,ip,j,bj,jp,k) = cbuff(cbuffindex)
178    #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO
179                         globfldyz(bi,ip,j,bj,jp,k) =
180         &                    globfldyz(bi,ip,j,bj,jp,k)/
181         &                    sqrt(weightfld(k,iobcs))
182    #endif
183                      else
184                         globfldyz(bi,ip,j,bj,jp,k) = 0. _d 0
185                      endif
186                    enddo
187                   enddo
188                  enddo
189                 enddo
190                enddo
191    c
192             enddo
193                
194             call MDSWRITEFIELD_YZ_GL( fname, ctrlprec, 'RL',
195         &                             Nr, globfldyz, irec,
196         &                             optimcycle, mythid)
197    cgg     &                             Nr, globfldyz, (irec-1)*nobcs+iobcs,
198    cgg     &                             optimcycle, mythid)
199    
200    c     -- end of iobcs loop -- This loop has been removed.
201    cgg     enddo
202    c     -- end of irec loop --
203          enddo
204    
205          _END_MASTER( mythid )
206    
207          return
208          end
209    
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2
  ViewVC Help
Powered by ViewVC 1.1.22