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

Diff of /MITgcm/pkg/ctrl/ctrl_set_unpack_xy.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_xy(
6         &     cunit, ivartype, fname, masktype, weighttype,
7         &     nwetglobal, mythid)
8    
9    c     ==================================================================
10    c     SUBROUTINE ctrl_set_unpack_xy
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          character*( 80) weighttype
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          _RL     globfld2d( snx,nsx,npx,sny,nsy,npy )
67    
68          character*(128) cfile
69          character*( 80) weightname
70    
71          integer        filenvartype
72          integer        filenvarlength
73          character*(10) fileExpId
74          integer        fileOptimCycle
75          integer        filencbuffindex
76          _RL            fileDummy
77          integer        fileIg
78          integer        fileJg
79          integer        fileI
80          integer        fileJ
81          integer        filensx
82          integer        filensy
83          integer        filek
84          integer        filencvarindex(maxcvars)
85          integer        filencvarrecs(maxcvars)
86          integer        filencvarxmax(maxcvars)
87          integer        filencvarymax(maxcvars)
88          integer        filencvarnrmax(maxcvars)
89          character*( 1) filencvargrd(maxcvars)
90    
91    c     == external ==
92    
93          integer  ilnblnk
94          external ilnblnk
95    
96    c     == 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                            do i = imin,imax
115                               globfld3d(i,bi,ip,j,bj,jp,k) = 0. _d 0
116                               globmsk  (i,bi,ip,j,bj,jp,k) = 0. _d 0
117                            enddo
118                         enddo
119                      enddo
120                   enddo
121                enddo
122             enddo
123          enddo
124    
125    #ifndef ALLOW_ECCO_OPTIMIZATION
126          optimcycle = 0
127    #endif
128    
129    c--   Only the master thread will do I/O.
130          _BEGIN_MASTER( mythid )
131    
132    #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO
133          il=ilnblnk( weighttype)
134          write(weightname(1:80),'(80a)') ' '
135          write(weightname(1:80),'(a)') weighttype(1:il)
136          call MDSREADFIELD_2D_GL(
137         &     weightname, ctrlprec, 'RL',
138         &     1, globfld2d, 1, mythid)
139    #endif
140          
141          call MDSREADFIELD_3D_GL(
142         &     masktype, ctrlprec, 'RL',
143         &     Nr, globmsk, 1, mythid)
144    
145          do irec = 1, ncvarrecs(ivartype)
146             read(cunit) filencvarindex(ivartype)
147             if (filencvarindex(ivartype) .NE. ncvarindex(ivartype))
148         &        then
149                print *, 'ctrl_set_unpack_xy:WARNING: wrong ncvarindex ',
150         &           filencvarindex(ivartype), ncvarindex(ivartype)
151                STOP 'in S/R ctrl_unpack'
152             endif
153             read(cunit) filej
154             read(cunit) filei
155             do k = 1,1
156                cbuffindex = nwetglobal(k)
157                if ( cbuffindex .gt. 0 ) then
158                   read(cunit) filencbuffindex
159                   if (filencbuffindex .NE. cbuffindex) then
160                      print *, 'WARNING: wrong cbuffindex ',
161         &                 filencbuffindex, cbuffindex
162                      STOP 'in S/R ctrl_unpack'
163                   endif
164                   read(cunit) filek
165                   if (filek .NE. k) then
166                      print *, 'WARNING: wrong k ',
167         &                 filek, k
168                      STOP 'in S/R ctrl_unpack'
169                   endif
170                   read(cunit) (cbuff(ii), ii=1,cbuffindex)
171                endif
172                cbuffindex = 0
173                do jp = 1,nPy
174                 do bj = jtlo,jthi
175                  do j = jmin,jmax
176                   do ip = 1,nPx
177                    do bi = itlo,ithi
178                     do i = imin,imax
179                      if ( globmsk(i,bi,ip,j,bj,jp,k) .ne. 0. ) then
180                         cbuffindex = cbuffindex + 1
181                         globfld3d(i,bi,ip,j,bj,jp,k) = cbuff(cbuffindex)
182    #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO
183                         globfld3d(i,bi,ip,j,bj,jp,k) =
184         &                    globfld3d(i,bi,ip,j,bj,jp,k)/
185         &                    sqrt(globfld2d(i,bi,ip,j,bj,jp))
186    #endif
187                      else
188                         globfld3d(i,bi,ip,j,bj,jp,k) = 0. _d 0
189                      endif
190                     enddo
191                    enddo
192                   enddo
193                  enddo
194                 enddo
195                enddo
196    c
197             enddo
198                
199             call MDSWRITEFIELD_2D_GL( fname, ctrlprec, 'RL',
200         &                             1, globfld3d(1,1,1,1,1,1,1),
201         &                             irec,  optimcycle, mythid)
202    
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