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

Diff of /MITgcm/pkg/ctrl/ctrl_set_pack_xz.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_xz(
6         &     cunit, ivartype, fname, masktype,
7         &     weightfld, lxxadxx, mythid)
8    
9    c     ==================================================================
10    c     SUBROUTINE ctrl_set_pack_xz
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*(  9) masktype
40          _RL     weightfld( nr,nobcs )
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,iobcs
56          integer itlo,ithi
57          integer jtlo,jthi
58          integer jmin,jmax
59          integer imin,imax
60    
61          integer cbuffindex
62    cgg(
63          integer igg
64          _RL     gg
65    cgg)
66    
67          _RL     cbuff      ( snx*nsx*npx*nsy*npy )
68          _RL     globmskxz  ( snx,nsx,npx,nsy,npy,nr )
69          _RL     globfldxz  ( snx,nsx,npx,nsy,npy,nr )
70    
71    c     == external ==
72    
73          integer  ilnblnk
74          external ilnblnk
75    
76    c     == end of interface ==
77    
78    #ifndef ALLOW_ECCO_OPTIMIZATION
79          optimcycle = 0
80    #endif
81    
82          jtlo = 1
83          jthi = nsy
84          itlo = 1
85          ithi = nsx
86          jmin = 1
87          jmax = sny
88          imin = 1
89          imax = snx
90    
91    c     Initialise temporary file
92          do k = 1,nr
93             do jp = 1,nPy
94                do bj = jtlo,jthi
95                   do ip = 1,nPx
96                      do bi = itlo,ithi
97                         do i = imin,imax
98                            globfldxz(i,bi,ip,bj,jp,k) = 0. _d 0
99                            globmskxz(i,bi,ip,bj,jp,k) = 0. _d 0
100                         enddo
101                      enddo
102                   enddo
103                enddo
104             enddo
105          enddo
106    
107    c--   Only the master thread will do I/O.
108          _BEGIN_MASTER( mythid )
109    
110          do irec = 1, ncvarrecs(ivartype)
111    cgg       do iobcs = 1, nobcs
112    cgg    Need to solve for what iobcs would have been.
113              gg   = (irec-1)/nobcs
114              igg  = int(gg)
115              iobcs = irec - igg*nobcs
116    
117             call MDSREADFIELD_XZ_GL(
118         &        masktype, ctrlprec, 'RL',
119         &        Nr, globmskxz, iobcs, mythid)
120    
121             call MDSREADFIELD_XZ_GL( fname, ctrlprec, 'RL',
122         &        nr, globfldxz, irec, mythid)
123    
124             write(cunit) ncvarindex(ivartype)
125             write(cunit) 1
126             write(cunit) 1
127             do k = 1,nr
128                cbuffindex = 0
129                do jp = 1,nPy
130                 do bj = jtlo,jthi
131                  do ip = 1,nPx
132                   do bi = itlo,ithi
133                    do i = imin,imax
134                     if (globmskxz(i,bi,ip,bj,jp,k)  .ne. 0. ) then
135                         cbuffindex = cbuffindex + 1
136    #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO
137                         if (lxxadxx) then
138                            cbuff(cbuffindex) =
139         &                       globfldxz(i,bi,ip,bj,jp,k) *
140         &                       sqrt(weightfld(k,iobcs))
141                         else
142                            cbuff(cbuffindex) =
143         &                       globfldxz(i,bi,ip,bj,jp,k) /
144         &                       sqrt(weightfld(k,iobcs))
145                         endif
146    #else
147                         cbuff(cbuffindex) = globfldxz(i,bi,ip,bj,jp,k)
148    #endif
149                     endif
150                    enddo
151                   enddo
152                  enddo
153                 enddo
154                enddo
155    c           --> check cbuffindex.
156                if ( cbuffindex .gt. 0) then
157                   write(cunit) cbuffindex
158                   write(cunit) k
159                   write(cunit) (cbuff(ii), ii=1,cbuffindex)
160                endif
161             enddo
162    c
163    c     -- end of iobcs loop --
164    cgg       enddo
165    c     -- end of irec loop --
166          enddo
167    
168          _END_MASTER( mythid )
169    
170          return
171          end
172    
173    
174    
175    
176    
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2
  ViewVC Help
Powered by ViewVC 1.1.22