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

Annotation of /MITgcm/pkg/ctrl/ctrl_set_unpack_xyz.F

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph

Revision 1.8 - (hide annotations) (download)
Tue Nov 16 05:42:12 2004 UTC (19 years, 6 months ago) by heimbach
Branch: MAIN
CVS Tags: checkpoint57b_post, checkpoint56b_post, checkpoint57, checkpoint56, checkpoint57a_post, checkpoint56a_post, checkpoint56c_post, checkpoint57a_pre
Changes since 1.7: +0 -11 lines 
More on dsvd vs. MITgcm interfacing
o handling of g_, ad, via admtlm_vector (mds...vector)
o use ctrl_pack/unpack for admtlm_vector I/O
o use optimcycle for dsvd iteration
o make sure norm is w.r.t. derived quantities
1 heimbach 1.2
2     #include "CTRL_CPPOPTIONS.h"
3    
4     subroutine ctrl_set_unpack_xyz(
5 heimbach 1.3 & cunit, ivartype, fname, masktype, weighttype,
6 heimbach 1.2 & weightfld, nwetglobal, mythid)
7    
8     c ==================================================================
9     c SUBROUTINE ctrl_set_unpack_xyz
10     c ==================================================================
11     c
12 heimbach 1.3 c o Unpack the control vector such that land points are filled in.
13     c
14     c o Use a more precise nondimensionalization that depends on (x,y)
15     c Added weighttype to the argument list so that I can geographically
16     c vary the nondimensionalization.
17     c gebbie@mit.edu, 18-Mar-2003
18 heimbach 1.2 c
19     c ==================================================================
20    
21     implicit none
22    
23     c == global variables ==
24    
25     #include "EEPARAMS.h"
26     #include "SIZE.h"
27     #include "PARAMS.h"
28     #include "GRID.h"
29    
30     #include "ctrl.h"
31     #include "optim.h"
32    
33     c == routine arguments ==
34    
35     integer cunit
36     integer ivartype
37     character*( 80) fname
38     character* (5) masktype
39 heimbach 1.3 character*( 80) weighttype
40 heimbach 1.2 _RL weightfld( nr,nsx,nsy )
41     integer nwetglobal(nr)
42     integer mythid
43    
44     c == local variables ==
45    
46     integer bi,bj
47     integer ip,jp
48     integer i,j,k
49     integer ii
50     integer il
51     integer irec
52     integer itlo,ithi
53     integer jtlo,jthi
54     integer jmin,jmax
55     integer imin,imax
56    
57     integer cbuffindex
58    
59 heimbach 1.6 real*4 cbuff ( snx*nsx*npx*sny*nsy*npy )
60 heimbach 1.2 _RL globmsk ( snx,nsx,npx,sny,nsy,npy,nr )
61     _RL globfld3d( snx,nsx,npx,sny,nsy,npy,nr )
62 heimbach 1.3 #ifdef CTRL_UNPACK_PRECISE
63     _RL weightfld3d( snx,nsx,npx,sny,nsy,npy,nr )
64     #endif
65 heimbach 1.2
66     character*(128) cfile
67 heimbach 1.3 character*(80) weightname
68 heimbach 1.2
69     c == external ==
70    
71     integer ilnblnk
72     external ilnblnk
73    
74     cc == end of interface ==
75    
76     jtlo = 1
77     jthi = nsy
78     itlo = 1
79     ithi = nsx
80     jmin = 1
81     jmax = sny
82     imin = 1
83     imax = snx
84    
85     c Initialise temporary file
86     do k = 1,nr
87     do jp = 1,nPy
88     do bj = jtlo,jthi
89     do j = jmin,jmax
90     do ip = 1,nPx
91     do bi = itlo,ithi
92     do i = imin,imax
93     globfld3d(i,bi,ip,j,bj,jp,k) = 0. _d 0
94     globmsk (i,bi,ip,j,bj,jp,k) = 0. _d 0
95     enddo
96     enddo
97     enddo
98     enddo
99     enddo
100     enddo
101     enddo
102    
103     c-- Only the master thread will do I/O.
104     _BEGIN_MASTER( mythid )
105    
106 heimbach 1.3 #ifdef CTRL_UNPACK_PRECISE
107     il=ilnblnk( weighttype)
108     write(weightname(1:80),'(80a)') ' '
109     write(weightname(1:80),'(a)') weighttype(1:il)
110    
111     call MDSREADFIELD_3D_GL(
112     & weightname, ctrlprec, 'RL',
113     & Nr, weightfld3d, 1, mythid)
114     #endif
115    
116 heimbach 1.2 call MDSREADFIELD_3D_GL(
117     & masktype, ctrlprec, 'RL',
118     & Nr, globmsk, 1, mythid)
119    
120     do irec = 1, ncvarrecs(ivartype)
121     read(cunit) filencvarindex(ivartype)
122     if (filencvarindex(ivartype) .NE. ncvarindex(ivartype))
123     & then
124     print *, 'ctrl_set_unpack_xyz:WARNING: wrong ncvarindex ',
125     & filencvarindex(ivartype), ncvarindex(ivartype)
126     STOP 'in S/R ctrl_unpack'
127     endif
128     read(cunit) filej
129     read(cunit) filei
130     do k = 1, Nr
131     cbuffindex = nwetglobal(k)
132     if ( cbuffindex .gt. 0 ) then
133     read(cunit) filencbuffindex
134     if (filencbuffindex .NE. cbuffindex) then
135     print *, 'WARNING: wrong cbuffindex ',
136     & filencbuffindex, cbuffindex
137     STOP 'in S/R ctrl_unpack'
138     endif
139     read(cunit) filek
140     if (filek .NE. k) then
141     print *, 'WARNING: wrong k ',
142     & filek, k
143     STOP 'in S/R ctrl_unpack'
144     endif
145     read(cunit) (cbuff(ii), ii=1,cbuffindex)
146     endif
147     cbuffindex = 0
148     do jp = 1,nPy
149     do bj = jtlo,jthi
150     do j = jmin,jmax
151     do ip = 1,nPx
152     do bi = itlo,ithi
153     do i = imin,imax
154     if ( globmsk(i,bi,ip,j,bj,jp,k) .ne. 0. ) then
155     cbuffindex = cbuffindex + 1
156     globfld3d(i,bi,ip,j,bj,jp,k) = cbuff(cbuffindex)
157     #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO
158     globfld3d(i,bi,ip,j,bj,jp,k) =
159     & globfld3d(i,bi,ip,j,bj,jp,k)/
160 heimbach 1.3 # ifdef CTRL_UNPACK_PRECISE
161     & sqrt(weightfld3d(i,bi,ip,j,bj,jp,k))
162     # else
163 heimbach 1.2 & sqrt(weightfld(k,bi,bj))
164 heimbach 1.3 # endif
165     #endif /* ALLOW_NONDIMENSIONAL_CONTROL_IO */
166 heimbach 1.2 else
167     globfld3d(i,bi,ip,j,bj,jp,k) = 0. _d 0
168     endif
169     enddo
170     enddo
171     enddo
172     enddo
173     enddo
174     enddo
175     c
176     enddo
177    
178     call MDSWRITEFIELD_3D_GL( fname, ctrlprec, 'RL',
179     & Nr, globfld3d,
180     & irec, optimcycle, mythid)
181    
182     enddo
183    
184     _END_MASTER( mythid )
185    
186     return
187     end
188    
  ViewVC Help
Powered by ViewVC 1.1.22