/[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.2 - (hide annotations) (download)
Sat Jul 13 02:47:32 2002 UTC (21 years, 10 months ago) by heimbach
Branch: MAIN
CVS Tags: checkpoint46n_post, checkpoint47e_post, checkpoint46l_post, checkpoint46g_pre, checkpoint47c_post, checkpoint50c_post, c49_ctrl, checkpoint46f_post, checkpoint48e_post, checkpoint50c_pre, checkpoint46b_post, checkpoint48i_post, checkpoint46l_pre, checkpoint50, checkpoint50d_post, checkpoint50b_pre, checkpoint48b_post, checkpoint48c_pre, checkpoint47d_pre, checkpoint47a_post, checkpoint48d_pre, checkpoint47i_post, checkpoint47d_post, checkpoint46d_pre, checkpoint48d_post, checkpoint48f_post, checkpoint46j_pre, checkpoint48h_post, checkpoint46a_post, checkpoint47g_post, checkpoint46j_post, checkpoint46k_post, checkpoint48a_post, checkpoint50f_post, checkpoint50a_post, checkpoint50f_pre, checkpoint47j_post, branch-exfmods-tag, checkpoint46e_pre, checkpoint48c_post, checkpoint46b_pre, checkpoint46c_pre, checkpoint46, checkpoint47b_post, checkpoint46h_pre, checkpoint46m_post, checkpoint46a_pre, checkpoint50g_post, checkpoint46g_post, checkpoint50h_post, checkpoint50e_pre, checkpoint50i_post, checkpoint47f_post, checkpoint50e_post, checkpoint46i_post, checkpoint46c_post, checkpoint50d_pre, checkpoint46e_post, checkpoint47, checkpoint48, checkpoint49, checkpoint46h_post, checkpoint48g_post, checkpoint47h_post, checkpoint46d_post, checkpoint50b_post
Branch point for: branch-exfmods-curt
Changes since 1.1: +198 -0 lines 
Merging new ctrl package from release1_p5:
o new ctrl package
  - adopted from ECCO environment to enable optimization
  - added Eliassen Palm fluxes to controls
1 heimbach 1.2
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    
  ViewVC Help
Powered by ViewVC 1.1.22