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

Diff of /MITgcm/pkg/ctrl/ctrl_set_pack_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_pack_xyz(
6         &     cunit, ivartype, fname, masktype,
7         &     weightfld, lxxadxx, mythid)
8    
9    c     ==================================================================
10    c     SUBROUTINE ctrl_set_pack_xyz
11    c     ==================================================================
12    c
13    c     o Compress the control vector such that only ocean points are
14    c       written to file.
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          logical lxxadxx
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    c     == external ==
68    
69          integer  ilnblnk
70          external ilnblnk
71    
72    c     == end of interface ==
73    
74    #ifndef ALLOW_ECCO_OPTIMIZATION
75          optimcycle = 0
76    #endif
77    
78          jtlo = 1
79          jthi = nsy
80          itlo = 1
81          ithi = nsx
82          jmin = 1
83          jmax = sny
84          imin = 1
85          imax = snx
86    
87    c     Initialise temporary file
88          do k = 1,nr
89             do jp = 1,nPy
90                do bj = jtlo,jthi
91                   do j = jmin,jmax
92                      do ip = 1,nPx
93                         do bi = itlo,ithi
94                            do i = imin,imax
95                               globfld3d(i,bi,ip,j,bj,jp,k) = 0. _d 0
96                               globmsk  (i,bi,ip,j,bj,jp,k) = 0. _d 0
97                            enddo
98                         enddo
99                      enddo
100                   enddo
101                enddo
102             enddo
103          enddo
104    
105    c--   Only the master thread will do I/O.
106          _BEGIN_MASTER( mythid )
107    
108          call MDSREADFIELD_3D_GL(
109         &     masktype, ctrlprec, 'RL',
110         &     Nr, globmsk, 1, mythid)
111    
112          do irec = 1, ncvarrecs(ivartype)
113    
114             call MDSREADFIELD_3D_GL( fname, ctrlprec, 'RL',
115         &        Nr, globfld3d, irec, mythid)
116    
117             write(cunit) ncvarindex(ivartype)
118             write(cunit) 1
119             write(cunit) 1
120             do k = 1, nr
121                cbuffindex = 0
122                do jp = 1,nPy
123                 do bj = jtlo,jthi
124                  do j = jmin,jmax
125                   do ip = 1,nPx
126                    do bi = itlo,ithi
127                     do i = imin,imax
128                      if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then
129                         cbuffindex = cbuffindex + 1
130    #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO
131                         if (lxxadxx) then
132                            cbuff(cbuffindex) =
133         &                       globfld3d(i,bi,ip,j,bj,jp,k) *
134         &                       sqrt(weightfld(k,bi,bj))
135                         else
136    cph(
137                            print *, 'ph-nondim bef. ', k, j, i,
138         &                       globfld3d(i,bi,ip,j,bj,jp,k),
139         &                       weightfld(k,bi,bj)
140    cph)
141                            cbuff(cbuffindex) =
142         &                       globfld3d(i,bi,ip,j,bj,jp,k) /
143         &                       sqrt(weightfld(k,bi,bj))
144    cph(
145                            write(6,'(A,4I5,F10.2)'), 'ph-nondim aft. ',
146         &                       k, j, i, cbuffindex,
147         &                       cbuff(cbuffindex)
148    cph)
149                         endif
150    #else
151                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)
152    #endif
153                      endif
154                     enddo
155                    enddo
156                   enddo
157                  enddo
158                 enddo
159                enddo
160    c           --> check cbuffindex.
161                if ( cbuffindex .gt. 0) then
162                   write(cunit) cbuffindex
163                   write(cunit) k
164                   write(cunit) (cbuff(ii), ii=1,cbuffindex)
165                endif
166             enddo
167    c
168    c     -- end of irec loop --
169          enddo
170    
171          _END_MASTER( mythid )
172    
173          return
174          end
175    
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2
  ViewVC Help
Powered by ViewVC 1.1.22