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

Diff of /MITgcm/pkg/ctrl/ctrl_pack.F

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

revision 1.1 by heimbach, Sun Mar 25 22:33:55 2001 UTC revision 1.21 by heimbach, Thu Jul 28 13:47:49 2005 UTC
# Line 1  Line 1 
1  C $Header$  C $Header$
2    C $Name$
3    
4    #include "PACKAGES_CONFIG.h"
5  #include "CTRL_CPPOPTIONS.h"  #include "CTRL_CPPOPTIONS.h"
6    
7          subroutine ctrl_pack( first, mythid )
       subroutine ctrl_pack(  
      I                      myiter,  
      I                      mytime,  
      I                      mythid  
      &                    )  
8    
9  c     ==================================================================  c     ==================================================================
10  c     SUBROUTINE ctrl_pack  c     SUBROUTINE ctrl_pack
# Line 26  c              Patrick Heimbach heimbach Line 23  c              Patrick Heimbach heimbach
23  c              - single file name convention with or without  c              - single file name convention with or without
24  c                ALLOW_ECCO_OPTIMIZATION  c                ALLOW_ECCO_OPTIMIZATION
25  c  c
26    c              G. Gebbie, added open boundary control packing,
27    c                  gebbie@mit.edu  18 -Mar- 2003
28    c
29    c              heimbach@mit.edu totally restructured 28-Oct-2003
30  c  c
31  c     ==================================================================  c     ==================================================================
32  c     SUBROUTINE ctrl_pack  c     SUBROUTINE ctrl_pack
# Line 41  c     == global variables == Line 42  c     == global variables ==
42  #include "GRID.h"  #include "GRID.h"
43    
44  #include "ctrl.h"  #include "ctrl.h"
45  #include "cost.h"  #include "optim.h"
46    
47    #ifdef ALLOW_COST
48    # include "cost.h"
49    #endif
50    #ifdef ALLOW_ECCO
51    # include "ecco_cost.h"
52    #else
53    # include "ctrl_weights.h"
54    #endif
55    
56  c     == routine arguments ==  c     == routine arguments ==
57    
58        integer myiter        logical first
       _RL     mytime  
59        integer mythid        integer mythid
60    
61    #ifndef EXCLUDE_CTRL_PACK
62  c     == local variables ==  c     == local variables ==
63    
64        integer bi,bj        _RL    fcloc
65        integer ip,jp  
66        integer i,j,k        integer i, j, k
67        integer ii        integer ii
68        integer il        integer il
69        integer irec        integer irec
70        integer itlo,ithi        integer ig,jg
71        integer jtlo,jthi        integer ivartype
72        integer jmin,jmax        integer iobcs
       integer imin,imax  
73    
74        logical doglobalread        logical doglobalread
75        logical ladinit        logical ladinit
76        integer cbuffindex        integer cbuffindex
77          logical lxxadxx
78          
79        integer cunit        integer cunit
80        _RL     cbuff( snx*nsx*npx*sny*nsy*npy )        integer ictrlgrad
       _RL     globfld3d( snx,nsx,npx,sny,nsy,npy,nr )  
       _RL     globfld2d( snx,nsx,npx,sny,nsy,npy )  
       _RL     globmsk( snx,nsx,npx,sny,nsy,npy,nr )  
       _RL     tmpvar  
81    
82        character*(128) cfile        character*(128) cfile
83        character*( 80) fname        character*( 80) weighttype
   
       integer prec  
84    
85  c     == external ==  c     == external ==
86    
# Line 85  c     == external == Line 89  c     == external ==
89    
90  c     == end of interface ==  c     == end of interface ==
91    
92        prec           = precFloat64  #ifndef ALLOW_ECCO_OPTIMIZATION
93        tmpvar         = -9999. _d 0        fmin       = 0. _d 0
94    #endif
       jtlo = 1  
       jthi = nsy  
       itlo = 1  
       ithi = nsx  
       jmin = 1  
       jmax = sny  
       imin = 1  
       imax = snx  
95    
96  c--   Tiled files are used.  c--   Tiled files are used.
97        doglobalread = .false.        doglobalread = .false.
# Line 103  c--   Tiled files are used. Line 99  c--   Tiled files are used.
99  c--   Initialise adjoint variables on active files.  c--   Initialise adjoint variables on active files.
100        ladinit = .false.        ladinit = .false.
101    
102  c  c--   Initialise global buffer index
103          nbuffglobal = 0
104    
105    c--   Assign file names.
106    
107          call ctrl_set_fname(xx_theta_file, fname_theta, mythid)
108          call ctrl_set_fname(xx_salt_file, fname_salt, mythid)
109          call ctrl_set_fname(xx_hflux_file, fname_hflux, mythid)
110          call ctrl_set_fname(xx_sflux_file, fname_sflux, mythid)
111          call ctrl_set_fname(xx_tauu_file, fname_tauu, mythid)
112          call ctrl_set_fname(xx_tauv_file, fname_tauv, mythid)
113          call ctrl_set_fname(xx_atemp_file, fname_atemp, mythid)
114          call ctrl_set_fname(xx_aqh_file, fname_aqh, mythid)
115          call ctrl_set_fname(xx_precip_file, fname_precip, mythid)
116          call ctrl_set_fname(xx_uwind_file, fname_uwind, mythid)
117          call ctrl_set_fname(xx_vwind_file, fname_vwind, mythid)
118          call ctrl_set_fname(xx_obcsn_file, fname_obcsn, mythid)
119          call ctrl_set_fname(xx_obcss_file, fname_obcss, mythid)
120          call ctrl_set_fname(xx_obcsw_file, fname_obcsw, mythid)
121          call ctrl_set_fname(xx_obcse_file, fname_obcse, mythid)
122          call ctrl_set_fname(xx_diffkr_file, fname_diffkr, mythid)
123          call ctrl_set_fname(xx_kapgm_file, fname_kapgm, mythid)
124          call ctrl_set_fname(xx_tr1_file, fname_tr1, mythid)
125          call ctrl_set_fname(xx_sst_file, fname_sst, mythid)
126          call ctrl_set_fname(xx_sss_file, fname_sss, mythid)
127          call ctrl_set_fname(xx_hfacc_file, fname_hfacc, mythid)
128          call ctrl_set_fname(xx_efluxy_file, fname_efluxy, mythid)
129          call ctrl_set_fname(xx_efluxp_file, fname_efluxp, mythid)
130          call ctrl_set_fname(xx_bottomdrag_file, fname_bottomdrag, mythid)
131          call ctrl_set_fname(xx_edtaux_file, fname_edtaux, mythid)
132          call ctrl_set_fname(xx_edtauy_file, fname_edtauy, mythid)
133          call ctrl_set_fname(xx_uvel_file, fname_uvel, mythid)
134          call ctrl_set_fname(xx_vvel_file, fname_vvel, mythid)
135          call ctrl_set_fname(xx_etan_file, fname_etan, mythid)
136          call ctrl_set_fname(xx_relaxsst_file, fname_relaxsst, mythid)
137          call ctrl_set_fname(xx_relaxsss_file, fname_relaxsss, mythid)
138    
139  c--   Only the master thread will do I/O.  c--   Only the master thread will do I/O.
140        _BEGIN_MASTER( mythid )        _BEGIN_MASTER( mythid )
141    
142  c--   read global mask file        if ( first ) then
143            call MDSREADFIELD_3D_GL( "hFacC",  c     >>> Initialise control vector for optimcycle=0 <<<
144       &                           prec, 'RL', Nr, globmsk,            lxxadxx   = .TRUE.
145       &                           1,  mythid)            ictrlgrad = 1
146              fcloc     = fmin
147              write(cfile(1:128),'(4a,i4.4)')
148  c     >>> Write control vector <<<       &         ctrlname(1:9),'_',yctrlid(1:10),
149         &         yctrlpospack, optimcycle
150            call mdsfindunit( cunit, mythid )            print *, 'ph-pack: packing ', ctrlname(1:9)
151            write(cfile(1:128),'(2a,i4.4)')        else
152       &      ctrlname(1:9),'.opt',  c     >>> Write gradient vector <<<
153       &      optimcycle            lxxadxx   = .FALSE.
154              ictrlgrad = 2
155            open( cunit, file   = cfile,            fcloc     = fc
156       &                 status = 'unknown',            write(cfile(1:128),'(4a,i4.4)')
157       &                 form   = 'unformatted',       &         costname(1:9),'_',yctrlid(1:10),
158       &                 access = 'sequential'   )       &         yctrlpospack, optimcycle
159              print *, 'ph-pack: packing ', costname(1:9)
160           endif
161    
162           call mdsfindunit( cunit, mythid )
163           open( cunit, file   = cfile,
164         &      status = 'unknown',
165         &      form   = 'unformatted',
166         &      access  = 'sequential'   )
167    
168  c--       Header information.  c--       Header information.
             
169            write(cunit) nvartype            write(cunit) nvartype
170            write(cunit) nvarlength            write(cunit) nvarlength
171            write(cunit) expId            write(cunit) yctrlid
172            write(cunit) optimCycle            write(cunit) optimCycle
173            write(cunit) tmpvar            write(cunit) fc
174            write(cunit) 1  C     place holder of obsolete variable iG
           write(cunit) 1  
           write(cunit) 1  
           write(cunit) 1  
           write(cunit) (nWetcTile(1,1,k), k=1,nr)  
           write(cunit) (nWetsTile(1,1,k), k=1,nr)  
           write(cunit) (nWetwTile(1,1,k), k=1,nr)  
           write(cunit) (ncvarindex(i), i=1,maxcvars)  
           write(cunit) (ncvarrecs(i),  i=1,maxcvars)  
           write(cunit) (nx,  i=1,maxcvars)  
           write(cunit) (ny,  i=1,maxcvars)  
           write(cunit) (ncvarnrmax(i), i=1,maxcvars)  
           write(cunit) (ncvargrd(i),   i=1,maxcvars)  
           write(cunit)  
   
 #ifdef ALLOW_THETA0_CONTROL  
   
           il=ilnblnk( xx_theta_file)  
           write(fname(1:80),'(80a)') ' '  
           write(fname(1:80),'(2a,i10.10)')  
      &         xx_theta_file(1:il),'.',optimcycle  
           call MDSREADFIELD_3D_GL( fname,  
      &                          prec, 'RL', Nr, globfld3d,  
      &                          1,  mythid)  
   
           write(cunit) ncvarindex(1)  
           write(cunit) 1  
           write(cunit) 1  
           do k = 1,nr  
            cbuffindex = 0  
             do jp = 1,nPy  
              do bj = jtlo,jthi  
               do j = jmin,jmax  
                do ip = 1,nPx  
                 do bi = itlo,ithi  
                  do i = imin,imax  
                     if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
                        cbuffindex = cbuffindex + 1  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
      &                      * sqrt(wtheta(k,bi,bj))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 #endif  
                     endif  
                  enddo  
                 enddo  
                enddo  
               enddo  
              enddo  
             enddo  
 c     --> check cbuffindex.  
             if ( cbuffindex .gt. 0) then  
                write(cunit) cbuffindex  
                write(cunit) k  
                write(cunit) (cbuff(ii), ii=1,cbuffindex)  
             endif  
          enddo  
   
 #endif  
   
 #ifdef ALLOW_SALT0_CONTROL  
   
           il=ilnblnk( xx_salt_file)  
           write(fname(1:80),'(80a)') ' '  
           write(fname(1:80),'(2a,i10.10)')  
      &         xx_salt_file(1:il),'.',optimcycle  
           call MDSREADFIELD_3D_GL( fname,  
      &                          prec, 'RL', Nr, globfld3d,  
      &                          1,  mythid)  
   
           write(cunit) ncvarindex(2)  
           write(cunit) 1  
           write(cunit) 1  
           do k = 1,nr  
            cbuffindex = 0  
             do jp = 1,nPy  
              do bj = jtlo,jthi  
               do j = jmin,jmax  
                do ip = 1,nPx  
                 do bi = itlo,ithi  
                  do i = imin,imax  
                     if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
                        cbuffindex = cbuffindex + 1  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
      &                      * sqrt(wsalt(k,bi,bj))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 #endif  
                     endif  
                  enddo  
                 enddo  
                enddo  
               enddo  
              enddo  
             enddo  
 c     --> check cbuffindex.  
             if ( cbuffindex .gt. 0) then  
                write(cunit) cbuffindex  
                write(cunit) k  
                write(cunit) (cbuff(ii), ii=1,cbuffindex)  
             endif  
          enddo  
               
 #endif  
   
 #ifdef ALLOW_HFLUX0_CONTROL  
   
           il=ilnblnk( xx_hflux_file)  
           write(fname(1:80),'(80a)') ' '  
           write(fname(1:80),'(2a,i10.10)')  
      &         xx_hflux_file(1:il),'.',optimcycle  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
           call MDSREADFIELD_2D_GL( "whflux",  
      &                          prec, 'RL', 1,  
      &                          globfld2d,  
      &                          1,  mythid)  
 #endif  
           call MDSREADFIELD_2D_GL( fname,  
      &                          prec, 'RL', 1,  
      &                          globfld3d(1,1,1,1,1,1,1),  
      &                          1,  mythid)  
   
           write(cunit) ncvarindex(3)  
           write(cunit) 1  
           write(cunit) 1  
           k = 1  
            cbuffindex = 0  
             do jp = 1,nPy  
              do bj = jtlo,jthi  
               do j = jmin,jmax  
                do ip = 1,nPx  
                 do bi = itlo,ithi  
                  do i = imin,imax  
                     if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
                        cbuffindex = cbuffindex + 1  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
      &                      * sqrt(globfld2d(i,bi,ip,j,bj,jp))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 #endif  
                     endif  
                  enddo  
                 enddo  
                enddo  
               enddo  
              enddo  
             enddo  
 c     --> check cbuffindex.  
             if ( cbuffindex .gt. 0) then  
                write(cunit) cbuffindex  
                write(cunit) k  
                write(cunit) (cbuff(ii), ii=1,cbuffindex)  
             endif  
   
 #endif  
   
 #ifdef ALLOW_SFLUX0_CONTROL  
   
           il=ilnblnk( xx_sflux_file)  
           write(fname(1:80),'(80a)') ' '  
           write(fname(1:80),'(2a,i10.10)')  
      &         xx_sflux_file(1:il),'.',optimcycle  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
           call MDSREADFIELD_2D_GL( "wsflux",  
      &                          prec, 'RL', 1,  
      &                          globfld2d,  
      &                          1,  mythid)  
 #endif  
           call MDSREADFIELD_2D_GL( fname,  
      &                          prec, 'RL', 1,  
      &                          globfld3d(1,1,1,1,1,1,1),  
      &                          1,  mythid)  
   
           write(cunit) ncvarindex(4)  
           write(cunit) 1  
           write(cunit) 1  
           k = 1  
            cbuffindex = 0  
             do jp = 1,nPy  
              do bj = jtlo,jthi  
               do j = jmin,jmax  
                do ip = 1,nPx  
                 do bi = itlo,ithi  
                  do i = imin,imax  
                     if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
                        cbuffindex = cbuffindex + 1  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
      &                      * sqrt(globfld2d(i,bi,ip,j,bj,jp))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 #endif  
                     endif  
                  enddo  
                 enddo  
                enddo  
               enddo  
              enddo  
             enddo  
 c     --> check cbuffindex.  
             if ( cbuffindex .gt. 0) then  
                write(cunit) cbuffindex  
                write(cunit) k  
                write(cunit) (cbuff(ii), ii=1,cbuffindex)  
             endif  
   
 #endif  
   
 #ifdef ALLOW_TAUU0_CONTROL  
   
           il=ilnblnk( xx_tauu_file)  
           write(fname(1:80),'(80a)') ' '  
           write(fname(1:80),'(2a,i10.10)')  
      &         xx_tauu_file(1:il),'.',optimcycle  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
           call MDSREADFIELD_2D_GL( "wtauu",  
      &                          prec, 'RL', 1,  
      &                          globfld2d,  
      &                          1,  mythid)  
 #endif  
           call MDSREADFIELD_2D_GL( fname,  
      &                          prec, 'RL', 1,  
      &                          globfld3d(1,1,1,1,1,1,1),  
      &                          1,  mythid)  
   
           write(cunit) ncvarindex(5)  
           write(cunit) 1  
           write(cunit) 1  
           k = 1  
            cbuffindex = 0  
             do jp = 1,nPy  
              do bj = jtlo,jthi  
               do j = jmin,jmax  
                do ip = 1,nPx  
                 do bi = itlo,ithi  
                  do i = imin,imax  
                     if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
                        cbuffindex = cbuffindex + 1  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
      &                      * sqrt(globfld2d(i,bi,ip,j,bj,jp))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 #endif  
                     endif  
                  enddo  
                 enddo  
                enddo  
               enddo  
              enddo  
             enddo  
 c     --> check cbuffindex.  
             if ( cbuffindex .gt. 0) then  
                write(cunit) cbuffindex  
                write(cunit) k  
                write(cunit) (cbuff(ii), ii=1,cbuffindex)  
             endif  
   
 #endif  
   
 #ifdef ALLOW_TAUV0_CONTROL  
   
           il=ilnblnk( xx_tauv_file)  
           write(fname(1:80),'(80a)') ' '  
           write(fname(1:80),'(2a,i10.10)')  
      &         xx_tauv_file(1:il),'.',optimcycle  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
           call MDSREADFIELD_2D_GL( "wtauv",  
      &                          prec, 'RL', 1,  
      &                          globfld2d,  
      &                          1,  mythid)  
 #endif  
           call MDSREADFIELD_2D_GL( fname,  
      &                          prec, 'RL', 1,  
      &                          globfld3d(1,1,1,1,1,1,1),  
      &                          1,  mythid)  
   
           write(cunit) ncvarindex(6)  
175            write(cunit) 1            write(cunit) 1
176    C     place holder of obsolete variable jG
177            write(cunit) 1            write(cunit) 1
178            k = 1            write(cunit) nsx
179             cbuffindex = 0            write(cunit) nsy
180              do jp = 1,nPy            write(cunit) (nWetcGlobal(k), k=1,nr)
181               do bj = jtlo,jthi            write(cunit) (nWetsGlobal(k), k=1,nr)
182                do j = jmin,jmax            write(cunit) (nWetwGlobal(k), k=1,nr)
183                 do ip = 1,nPx  #ifdef ALLOW_CTRL_WETV
184                  do bi = itlo,ithi            write(cunit) (nWetvGlobal(k), k=1,nr)
                  do i = imin,imax  
                     if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
                        cbuffindex = cbuffindex + 1  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
      &                      * sqrt(globfld2d(i,bi,ip,j,bj,jp))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
185  #endif  #endif
                     endif  
                  enddo  
                 enddo  
                enddo  
               enddo  
              enddo  
             enddo  
 c     --> check cbuffindex.  
             if ( cbuffindex .gt. 0) then  
                write(cunit) cbuffindex  
                write(cunit) k  
                write(cunit) (cbuff(ii), ii=1,cbuffindex)  
             endif  
186    
187    #ifdef ALLOW_OBCSN_CONTROL
188              write(cunit) ((nWetobcsnGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
189  #endif  #endif
190    #ifdef ALLOW_OBCSS_CONTROL
191  #ifdef ALLOW_SST0_CONTROL            write(cunit) ((nWetobcssGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
   
           il=ilnblnk( xx_sst_file)  
           write(fname(1:80),'(80a)') ' '  
           write(fname(1:80),'(2a,i10.10)')  
      &         xx_sst_file(1:il),'.',optimcycle  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
           call MDSREADFIELD_2D_GL( "wsst",  
      &                          prec, 'RL', 1,  
      &                          globfld2d,  
      &                          1,  mythid)  
 #endif  
           call MDSREADFIELD_2D_GL( fname,  
      &                          prec, 'RL', 1,  
      &                          globfld3d(1,1,1,1,1,1,1),  
      &                          1,  mythid)  
   
           write(cunit) ncvarindex(7)  
           write(cunit) 1  
           write(cunit) 1  
           k = 1  
            cbuffindex = 0  
             do jp = 1,nPy  
              do bj = jtlo,jthi  
               do j = jmin,jmax  
                do ip = 1,nPx  
                 do bi = itlo,ithi  
                  do i = imin,imax  
                     if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
                        cbuffindex = cbuffindex + 1  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
      &                      * sqrt(globfld2d(i,bi,ip,j,bj,jp))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
192  #endif  #endif
193                      endif  #ifdef ALLOW_OBCSW_CONTROL
194                   enddo            write(cunit) ((nWetobcswGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
                 enddo  
                enddo  
               enddo  
              enddo  
             enddo  
 c     --> check cbuffindex.  
             if ( cbuffindex .gt. 0) then  
                write(cunit) cbuffindex  
                write(cunit) k  
                write(cunit) (cbuff(ii), ii=1,cbuffindex)  
             endif  
   
195  #endif  #endif
196    #ifdef ALLOW_OBCSE_CONTROL
197  #ifdef ALLOW_SSS0_CONTROL            write(cunit) ((nWetobcseGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
   
           il=ilnblnk( xx_sss_file)  
           write(fname(1:80),'(80a)') ' '  
           write(fname(1:80),'(2a,i10.10)')  
      &         xx_sss_file(1:il),'.',optimcycle  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
           call MDSREADFIELD_2D_GL( "wsss",  
      &                          prec, 'RL', 1,  
      &                          globfld2d,  
      &                          1,  mythid)  
 #endif  
           call MDSREADFIELD_2D_GL( fname,  
      &                          prec, 'RL', 1,  
      &                          globfld3d(1,1,1,1,1,1,1),  
      &                          1,  mythid)  
   
           write(cunit) ncvarindex(8)  
           write(cunit) 1  
           write(cunit) 1  
           k = 1  
            cbuffindex = 0  
             do jp = 1,nPy  
              do bj = jtlo,jthi  
               do j = jmin,jmax  
                do ip = 1,nPx  
                 do bi = itlo,ithi  
                  do i = imin,imax  
                     if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
                        cbuffindex = cbuffindex + 1  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
      &                      * sqrt(globfld2d(i,bi,ip,j,bj,jp))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
198  #endif  #endif
                     endif  
                  enddo  
                 enddo  
                enddo  
               enddo  
              enddo  
             enddo  
 c     --> check cbuffindex.  
             if ( cbuffindex .gt. 0) then  
                write(cunit) cbuffindex  
                write(cunit) k  
                write(cunit) (cbuff(ii), ii=1,cbuffindex)  
             endif  
   
 #endif  
   
   
           close ( cunit )  
   
         _END_MASTER( mythid )  
   
 c======================================================================  
   
 c--   read global mask file  
           call MDSREADFIELD_3D_GL( "hFacC",  
      &                           prec, 'RL', Nr, globmsk,  
      &                           1,  mythid)  
   
 c     >>> Write gradient vector <<<  
   
           call mdsfindunit( cunit, mythid )  
           write(cfile(1:128),'(2a,i4.4)')  
      &    costname(1:9),'.opt',  
      &    optimcycle  
   
           open( cunit, file   = cfile,  
      &               status = 'unknown',  
      &               form   = 'unformatted',  
      &               access  = 'sequential'   )  
   
 c--       Header information.  
           write(cunit) nvartype  
           write(cunit) nvarlength  
           write(cunit) expId  
           write(cunit) optimCycle  
           write(cunit) fc  
           write(cunit) 1  
           write(cunit) 1  
           write(cunit) 1  
           write(cunit) 1  
           write(cunit) (nWetcTile(1,1,k), k=1,nr)  
           write(cunit) (nWetsTile(1,1,k), k=1,nr)  
           write(cunit) (nWetwTile(1,1,k), k=1,nr)  
199            write(cunit) (ncvarindex(i), i=1,maxcvars)            write(cunit) (ncvarindex(i), i=1,maxcvars)
200            write(cunit) (ncvarrecs(i),  i=1,maxcvars)            write(cunit) (ncvarrecs(i),  i=1,maxcvars)
201            write(cunit) (nx,  i=1,maxcvars)            write(cunit) (ncvarxmax(i),  i=1,maxcvars)
202            write(cunit) (ny,  i=1,maxcvars)            write(cunit) (ncvarymax(i),  i=1,maxcvars)
203            write(cunit) (ncvarnrmax(i), i=1,maxcvars)            write(cunit) (ncvarnrmax(i), i=1,maxcvars)
204            write(cunit) (ncvargrd(i),   i=1,maxcvars)            write(cunit) (ncvargrd(i),   i=1,maxcvars)
205            write(cunit)            write(cunit)
206    
207  #ifdef ALLOW_THETA0_CONTROL  #ifdef ALLOW_THETA0_CONTROL
208              ivartype = 1
209            il=ilnblnk( xx_theta_file)            write(weighttype(1:80),'(80a)') ' '
210            write(fname(1:80),'(80a)') ' '            write(weighttype(1:80),'(a)') "wtheta"
211            write(fname(1:80),'(3a,i10.10)')            call ctrl_set_pack_xyz(
212       &         yadmark,xx_theta_file(1:il),'.',optimcycle       &         cunit, ivartype, fname_theta(ictrlgrad), "maskCtrlC",
213         &         weighttype, wtheta, lxxadxx, mythid)
           call MDSREADFIELD_3D_GL( fname,  
      &                          prec, 'RL', Nr,  
      &                          globfld3d,  
      &                          1,  mythid)  
             
           write(cunit) ncvarindex(1)  
           write(cunit) 1  
           write(cunit) 1  
           do k = 1,nr  
            cbuffindex = 0  
             do jp = 1,nPy  
              do bj = jtlo,jthi  
               do j = jmin,jmax  
                do ip = 1,nPx  
                 do bi = itlo,ithi  
                  do i = imin,imax  
                     if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
                        cbuffindex = cbuffindex + 1  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
      &                      * sqrt(wtheta(k,bi,bj))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 #endif  
                     endif  
                  enddo  
                 enddo  
                enddo  
               enddo  
              enddo  
             enddo  
 c     --> check cbuffindex.  
             if ( cbuffindex .gt. 0) then  
                write(cunit) cbuffindex  
                write(cunit) k  
                write(cunit) (cbuff(ii), ii=1,cbuffindex)  
             endif  
          enddo  
   
214  #endif  #endif
215    
216  #ifdef ALLOW_SALT0_CONTROL  #ifdef ALLOW_SALT0_CONTROL
217              ivartype = 2
218            il=ilnblnk( xx_salt_file)            write(weighttype(1:80),'(80a)') ' '
219            write(fname(1:80),'(80a)') ' '            write(weighttype(1:80),'(a)') "wsalt"
220            write(fname(1:80),'(3a,i10.10)')            call ctrl_set_pack_xyz(
221       &         yadmark,xx_salt_file(1:il),'.',optimcycle       &         cunit, ivartype, fname_salt(ictrlgrad), "maskCtrlC",
222         &         weighttype, wsalt, lxxadxx, mythid)
223            call MDSREADFIELD_3D_GL( fname,  #endif
224       &                          prec, 'RL', Nr,  
225       &                          globfld3d,  #if (defined (ALLOW_HFLUX_CONTROL) || \
226       &                          1,  mythid)       defined (ALLOW_HFLUX0_CONTROL))
227                        ivartype = 3
228            write(cunit) ncvarindex(2)            write(weighttype(1:80),'(80a)') ' '
229            write(cunit) 1            write(weighttype(1:80),'(a)') "whflux"
230            write(cunit) 1            call ctrl_set_pack_xy(
231            do k = 1,nr       &         cunit, ivartype, fname_hflux(ictrlgrad), "maskCtrlC",
232             cbuffindex = 0       &         weighttype, lxxadxx, mythid)
233              do jp = 1,nPy  #endif
234               do bj = jtlo,jthi  
235                do j = jmin,jmax  #if (defined (ALLOW_SFLUX_CONTROL) || \
236                 do ip = 1,nPx       defined (ALLOW_SFLUX0_CONTROL))
237                  do bi = itlo,ithi            ivartype = 4
238                   do i = imin,imax            write(weighttype(1:80),'(80a)') ' '
239                      if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then            write(weighttype(1:80),'(a)') "wsflux"
240                         cbuffindex = cbuffindex + 1            call ctrl_set_pack_xy(
241  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO       &         cunit, ivartype, fname_sflux(ictrlgrad), "maskCtrlC",
242                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)       &         weighttype, lxxadxx, mythid)
243       &                      * sqrt(wsalt(k,bi,bj))  #endif
244  #else  
245                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  #if (defined (ALLOW_USTRESS_CONTROL) || \
246  #endif       defined (ALLOW_TAUU0_CONTROL))
247                      endif            ivartype = 5
248                   enddo            write(weighttype(1:80),'(80a)') ' '
249                  enddo            write(weighttype(1:80),'(a)') "wtauu"
250                 enddo            call ctrl_set_pack_xy(
251                enddo       &         cunit, ivartype, fname_tauu(ictrlgrad), "maskCtrlW",
252               enddo       &         weighttype, lxxadxx, mythid)
253              enddo  #endif
254  c     --> check cbuffindex.  
255              if ( cbuffindex .gt. 0) then  #if (defined (ALLOW_VSTRESS_CONTROL) || \
256                 write(cunit) cbuffindex       defined (ALLOW_TAUV0_CONTROL))
257                 write(cunit) k            ivartype = 6
258                 write(cunit) (cbuff(ii), ii=1,cbuffindex)            write(weighttype(1:80),'(80a)') ' '
259              endif            write(weighttype(1:80),'(a)') "wtauv"
260           enddo            call ctrl_set_pack_xy(
261         &         cunit, ivartype, fname_tauv(ictrlgrad), "maskCtrlS",
262  #endif       &         weighttype, lxxadxx, mythid)
263    #endif
264    
265  #ifdef ALLOW_HFLUX0_CONTROL  #ifdef ALLOW_ATEMP_CONTROL
266              ivartype = 7
267            il=ilnblnk( xx_hflux_file)            write(weighttype(1:80),'(80a)') ' '
268            write(fname(1:80),'(80a)') ' '            write(weighttype(1:80),'(a)') "watemp"
269            write(fname(1:80),'(3a,i10.10)')            call ctrl_set_pack_xy(
270       &         yadmark,xx_hflux_file(1:il),'.',optimcycle       &         cunit, ivartype, fname_atemp(ictrlgrad), "maskCtrlC",
271  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO       &         weighttype, lxxadxx, mythid)
272            call MDSREADFIELD_2D_GL( "whflux",  #endif
273       &                          prec, 'RL', 1,  
274       &                          globfld2d,  #ifdef ALLOW_AQH_CONTROL
275       &                          1,  mythid)            ivartype = 8
276  #endif            write(weighttype(1:80),'(80a)') ' '
277            call MDSREADFIELD_2D_GL( fname,            write(weighttype(1:80),'(a)') "waqh"
278       &                          prec, 'RL', 1,            call ctrl_set_pack_xy(
279       &                          globfld3d(1,1,1,1,1,1,1),       &         cunit, ivartype, fname_aqh(ictrlgrad), "maskCtrlC",
280       &                          1,  mythid)       &         weighttype, lxxadxx, mythid)
281    #endif
282            write(cunit) ncvarindex(3)  
283            write(cunit) 1  #ifdef ALLOW_UWIND_CONTROL
284            write(cunit) 1            ivartype = 9
285            k = 1            write(weighttype(1:80),'(80a)') ' '
286             cbuffindex = 0            write(weighttype(1:80),'(a)') "wuwind"
287              do jp = 1,nPy            call ctrl_set_pack_xy(
288               do bj = jtlo,jthi       &         cunit, ivartype, fname_uwind(ictrlgrad), "maskCtrlC",
289                do j = jmin,jmax       &         weighttype, lxxadxx, mythid)
290                 do ip = 1,nPx  #endif
291                  do bi = itlo,ithi  
292                   do i = imin,imax  #ifdef ALLOW_VWIND_CONTROL
293                      if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then            ivartype = 10
294                         cbuffindex = cbuffindex + 1            write(weighttype(1:80),'(80a)') ' '
295  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO            write(weighttype(1:80),'(a)') "wvwind"
296                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)            call ctrl_set_pack_xy(
297       &                      * sqrt(globfld2d(i,bi,ip,j,bj,jp))       &         cunit, ivartype, fname_vwind(ictrlgrad), "maskCtrlC",
298  #else       &         weighttype, lxxadxx, mythid)
299                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  #endif
300  #endif  
301                      endif  #ifdef ALLOW_OBCSN_CONTROL
302                   enddo            ivartype = 11
303                  enddo            write(weighttype(1:80),'(80a)') ' '
304                 enddo            write(weighttype(1:80),'(a)') "wobcsn"
305                enddo            call ctrl_set_pack_xz(
306               enddo       &         cunit, ivartype, fname_obcsn(ictrlgrad), "maskobcsn",
307              enddo       &         weighttype, wobcsn, lxxadxx, mythid)
308  c     --> check cbuffindex.  #endif
309              if ( cbuffindex .gt. 0) then  
310                 write(cunit) cbuffindex  #ifdef ALLOW_OBCSS_CONTROL
311                 write(cunit) k            ivartype = 12
312                 write(cunit) (cbuff(ii), ii=1,cbuffindex)            write(weighttype(1:80),'(80a)') ' '
313              endif            write(weighttype(1:80),'(a)') "wobcss"
314              call ctrl_set_pack_xz(
315  #endif       &         cunit, ivartype, fname_obcss(ictrlgrad), "maskobcss",
316         &         weighttype, wobcss, lxxadxx, mythid)
317  #ifdef ALLOW_SFLUX0_CONTROL  #endif
318    
319            il=ilnblnk( xx_sflux_file)  #ifdef ALLOW_OBCSW_CONTROL
320            write(fname(1:80),'(80a)') ' '            ivartype = 13
321            write(fname(1:80),'(3a,i10.10)')            write(weighttype(1:80),'(80a)') ' '
322       &         yadmark,xx_sflux_file(1:il),'.',optimcycle            write(weighttype(1:80),'(a)') "wobcsw"
323  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO            call ctrl_set_pack_yz(
324            call MDSREADFIELD_2D_GL( "wsflux",       &         cunit, ivartype, fname_obcsw(ictrlgrad), "maskobcsw",
325       &                          prec, 'RL', 1,       &         weighttype, wobcsw, lxxadxx, mythid)
326       &                          globfld2d,  #endif
327       &                          1,  mythid)  
328  #endif  #ifdef ALLOW_OBCSE_CONTROL
329            call MDSREADFIELD_2D_GL( fname,            ivartype = 14
330       &                          prec, 'RL', 1,            write(weighttype(1:80),'(80a)') ' '
331       &                          globfld3d(1,1,1,1,1,1,1),            write(weighttype(1:80),'(a)') "wobcse"
332       &                          1,  mythid)            call ctrl_set_pack_yz(
333         &         cunit, ivartype, fname_obcse(ictrlgrad), "maskobcse",
334            write(cunit) ncvarindex(4)       &         weighttype, wobcse, lxxadxx, mythid)
335            write(cunit) 1  #endif
336            write(cunit) 1  
337            k = 1  #ifdef ALLOW_DIFFKR_CONTROL
338             cbuffindex = 0            ivartype = 15
339              do jp = 1,nPy            write(weighttype(1:80),'(80a)') ' '
340               do bj = jtlo,jthi            write(weighttype(1:80),'(a)') "wdiffkr"
341                do j = jmin,jmax            call ctrl_set_pack_xyz(
342                 do ip = 1,nPx       &         cunit, ivartype, fname_diffkr(ictrlgrad), "maskCtrlC",
343                  do bi = itlo,ithi       &         weighttype, wunit, lxxadxx, mythid)
344                   do i = imin,imax  #endif
345                      if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
346                         cbuffindex = cbuffindex + 1  #ifdef ALLOW_KAPGM_CONTROL
347  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO            ivartype = 16
348                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)            write(weighttype(1:80),'(80a)') ' '
349       &                      * sqrt(globfld2d(i,bi,ip,j,bj,jp))            write(weighttype(1:80),'(a)') "wkapgm"
350  #else            call ctrl_set_pack_xyz(
351                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)       &         cunit, ivartype, fname_kapgm(ictrlgrad), "maskCtrlC",
352  #endif       &         weighttype, wunit, lxxadxx, mythid)
353                      endif  #endif
354                   enddo  
355                  enddo  #ifdef ALLOW_PRECIP_CONTROL
356                 enddo            ivartype = 17
357                enddo            write(weighttype(1:80),'(80a)') ' '
358               enddo            write(weighttype(1:80),'(a)') "wprecip"
359              enddo            call ctrl_set_pack_xy(
360  c     --> check cbuffindex.       &         cunit, ivartype, fname_precip(ictrlgrad), "maskCtrlC",
361              if ( cbuffindex .gt. 0) then       &         weighttype, lxxadxx, mythid)
                write(cunit) cbuffindex  
                write(cunit) k  
                write(cunit) (cbuff(ii), ii=1,cbuffindex)  
             endif  
   
 #endif  
   
 #ifdef ALLOW_TAUU0_CONTROL  
   
           il=ilnblnk( xx_tauu_file)  
           write(fname(1:80),'(80a)') ' '  
           write(fname(1:80),'(3a,i10.10)')  
      &         yadmark,xx_tauu_file(1:il),'.',optimcycle  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
           call MDSREADFIELD_2D_GL( "wtauu",  
      &                          prec, 'RL', 1,  
      &                          globfld2d,  
      &                          1,  mythid)  
 #endif  
           call MDSREADFIELD_2D_GL( fname,  
      &                          prec, 'RL', 1,  
      &                          globfld3d(1,1,1,1,1,1,1),  
      &                          1,  mythid)  
   
           write(cunit) ncvarindex(5)  
           write(cunit) 1  
           write(cunit) 1  
           k = 1  
            cbuffindex = 0  
             do jp = 1,nPy  
              do bj = jtlo,jthi  
               do j = jmin,jmax  
                do ip = 1,nPx  
                 do bi = itlo,ithi  
                  do i = imin,imax  
                     if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
                        cbuffindex = cbuffindex + 1  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
      &                      * sqrt(globfld2d(i,bi,ip,j,bj,jp))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 #endif  
                     endif  
                  enddo  
                 enddo  
                enddo  
               enddo  
              enddo  
             enddo  
 c     --> check cbuffindex.  
             if ( cbuffindex .gt. 0) then  
                write(cunit) cbuffindex  
                write(cunit) k  
                write(cunit) (cbuff(ii), ii=1,cbuffindex)  
             endif  
   
 #endif  
   
 #ifdef ALLOW_TAUV0_CONTROL  
   
           il=ilnblnk( xx_tauv_file)  
           write(fname(1:80),'(80a)') ' '  
           write(fname(1:80),'(3a,i10.10)')  
      &         yadmark,xx_tauv_file(1:il),'.',optimcycle  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
           call MDSREADFIELD_2D_GL( "wtauv",  
      &                          prec, 'RL', 1,  
      &                          globfld2d,  
      &                          1,  mythid)  
 #endif  
           call MDSREADFIELD_2D_GL( fname,  
      &                          prec, 'RL', 1,  
      &                          globfld3d(1,1,1,1,1,1,1),  
      &                          1,  mythid)  
   
           write(cunit) ncvarindex(6)  
           write(cunit) 1  
           write(cunit) 1  
           k = 1  
            cbuffindex = 0  
             do jp = 1,nPy  
              do bj = jtlo,jthi  
               do j = jmin,jmax  
                do ip = 1,nPx  
                 do bi = itlo,ithi  
                  do i = imin,imax  
                     if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
                        cbuffindex = cbuffindex + 1  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
      &                      * sqrt(globfld2d(i,bi,ip,j,bj,jp))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 #endif  
                     endif  
                  enddo  
                 enddo  
                enddo  
               enddo  
              enddo  
             enddo  
 c     --> check cbuffindex.  
             if ( cbuffindex .gt. 0) then  
                write(cunit) cbuffindex  
                write(cunit) k  
                write(cunit) (cbuff(ii), ii=1,cbuffindex)  
             endif  
   
362  #endif  #endif
363    
364  #ifdef ALLOW_SST0_CONTROL  #ifdef ALLOW_SST0_CONTROL
365              ivartype = 18
366            il=ilnblnk( xx_sst_file)            write(weighttype(1:80),'(80a)') ' '
367            write(fname(1:80),'(80a)') ' '            write(weighttype(1:80),'(a)') "wsst0"
368            write(fname(1:80),'(3a,i10.10)')            call ctrl_set_pack_xy(
369       &         yadmark,xx_sst_file(1:il),'.',optimcycle       &         cunit, ivartype, fname_sst(ictrlgrad), "maskCtrlC",
370  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO       &         weighttype, lxxadxx, mythid)
           call MDSREADFIELD_2D_GL( "wsst",  
      &                          prec, 'RL', 1,  
      &                          globfld2d,  
      &                          1,  mythid)  
 #endif  
           call MDSREADFIELD_2D_GL( fname,  
      &                          prec, 'RL', 1,  
      &                          globfld3d(1,1,1,1,1,1,1),  
      &                          1,  mythid)  
   
           write(cunit) ncvarindex(7)  
           write(cunit) 1  
           write(cunit) 1  
           k = 1  
            cbuffindex = 0  
             do jp = 1,nPy  
              do bj = jtlo,jthi  
               do j = jmin,jmax  
                do ip = 1,nPx  
                 do bi = itlo,ithi  
                  do i = imin,imax  
                     if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
                        cbuffindex = cbuffindex + 1  
 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
      &                      * sqrt(globfld2d(i,bi,ip,j,bj,jp))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
 #endif  
                     endif  
                  enddo  
                 enddo  
                enddo  
               enddo  
              enddo  
             enddo  
 c     --> check cbuffindex.  
             if ( cbuffindex .gt. 0) then  
                write(cunit) cbuffindex  
                write(cunit) k  
                write(cunit) (cbuff(ii), ii=1,cbuffindex)  
             endif  
   
371  #endif  #endif
372    
373  #ifdef ALLOW_SSS0_CONTROL  #ifdef ALLOW_SSS0_CONTROL
374              ivartype = 19
375            il=ilnblnk( xx_sss_file)            write(weighttype(1:80),'(80a)') ' '
376            write(fname(1:80),'(80a)') ' '            write(weighttype(1:80),'(a)') "wsss0"
377            write(fname(1:80),'(3a,i10.10)')            call ctrl_set_pack_xy(
378       &         yadmark,xx_sss_file(1:il),'.',optimcycle       &         cunit, ivartype, fname_sss(ictrlgrad), "maskCtrlC",
379  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO       &         weighttype, lxxadxx, mythid)
380            call MDSREADFIELD_2D_GL( "wsss",  #endif
381       &                          prec, 'RL', 1,  
382       &                          globfld2d,  #ifdef ALLOW_HFACC_CONTROL
383       &                          1,  mythid)            ivartype = 20
384  #endif            write(weighttype(1:80),'(80a)') ' '
385            call MDSREADFIELD_2D_GL( fname,            write(weighttype(1:80),'(a)') "whfacc"
386       &                          prec, 'RL', 1,  # ifdef ALLOW_HFACC3D_CONTROL
387       &                          globfld3d(1,1,1,1,1,1,1),            call ctrl_set_pack_xyz(
388       &                          1,  mythid)       &         cunit, ivartype, fname_hfacc(ictrlgrad), "maskCtrlC",
389         &         weighttype, wunit, lxxadxx, mythid)
390            write(cunit) ncvarindex(8)  # else
391            write(cunit) 1            call ctrl_set_pack_xy(
392            write(cunit) 1       &         cunit, ivartype, fname_hfacc(ictrlgrad), "maskCtrlC",
393            k = 1       &         weighttype, lxxadxx, mythid)
394             cbuffindex = 0  # endif
395              do jp = 1,nPy  #endif
396               do bj = jtlo,jthi  
397                do j = jmin,jmax  #ifdef ALLOW_EFLUXY0_CONTROL
398                 do ip = 1,nPx            ivartype = 21
399                  do bi = itlo,ithi            write(weighttype(1:80),'(80a)') ' '
400                   do i = imin,imax            write(weighttype(1:80),'(a)') "wefluxy0"
401                      if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then            call ctrl_set_pack_xyz(
402                         cbuffindex = cbuffindex + 1       &         cunit, ivartype, fname_efluxy(ictrlgrad), "maskCtrlS",
403  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO       &         weighttype, wunit, lxxadxx, mythid)
404                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  #endif
405       &                      * sqrt(globfld2d(i,bi,ip,j,bj,jp))  
406  #else  #ifdef ALLOW_EFLUXP0_CONTROL
407                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)            ivartype = 22
408  #endif            write(weighttype(1:80),'(80a)') ' '
409                      endif            write(weighttype(1:80),'(a)') "wefluxp0"
410                   enddo            call ctrl_set_pack_xyz(
411                  enddo       &         cunit, ivartype, fname_efluxp(ictrlgrad), "maskhFacV",
412                 enddo       &         weighttype, wunit, lxxadxx, mythid)
413                enddo  #endif
414               enddo  
415              enddo  #ifdef ALLOW_BOTTOMDRAG_CONTROL
416  c     --> check cbuffindex.            ivartype = 23
417              if ( cbuffindex .gt. 0) then            write(weighttype(1:80),'(80a)') ' '
418                 write(cunit) cbuffindex            write(weighttype(1:80),'(a)') "wbottomdrag"
419                 write(cunit) k            call ctrl_set_pack_xy(
420                 write(cunit) (cbuff(ii), ii=1,cbuffindex)       &      cunit, ivartype, fname_bottomdrag(ictrlgrad), "maskCtrlC",
421              endif       &      weighttype, lxxadxx, mythid)
422    #endif
423    
424    #ifdef ALLOW_EDTAUX_CONTROL
425              ivartype = 25
426              write(weighttype(1:80),'(80a)') ' '
427              write(weighttype(1:80),'(a)') "wedtaux"
428              call ctrl_set_pack_xyz(
429         &         cunit, ivartype, fname_edtaux(ictrlgrad), "maskCtrlW",
430         &         weighttype, wunit, lxxadxx, mythid)
431    #endif
432    
433    #ifdef ALLOW_EDTAUY_CONTROL
434              ivartype = 26
435              write(weighttype(1:80),'(80a)') ' '
436              write(weighttype(1:80),'(a)') "wedtauy"
437              call ctrl_set_pack_xyz(
438         &         cunit, ivartype, fname_edtauy(ictrlgrad), "maskCtrlS",
439         &         weighttype, wunit, lxxadxx, mythid)
440    #endif
441    
442    #ifdef ALLOW_UVEL0_CONTROL
443              ivartype = 27
444              write(weighttype(1:80),'(80a)') ' '
445              write(weighttype(1:80),'(a)') "wuvel"
446              call ctrl_set_pack_xyz(
447         &         cunit, ivartype, fname_uvel(ictrlgrad), "maskCtrlW",
448         &         weighttype, wunit, lxxadxx, mythid)
449    #endif
450    
451    #ifdef ALLOW_VVEL0_CONTROL
452              ivartype = 28
453              write(weighttype(1:80),'(80a)') ' '
454              write(weighttype(1:80),'(a)') "wvvel"
455              call ctrl_set_pack_xyz(
456         &         cunit, ivartype, fname_vvel(ictrlgrad), "maskCtrlS",
457         &         weighttype, wunit, lxxadxx, mythid)
458    #endif
459    
460    #ifdef ALLOW_ETAN0_CONTROL
461              ivartype = 29
462              write(weighttype(1:80),'(80a)') ' '
463              write(weighttype(1:80),'(a)') "wetan"
464              call ctrl_set_pack_xy(
465         &         cunit, ivartype, fname_etan(ictrlgrad), "maskCtrlC",
466         &         weighttype, lxxadxx, mythid)
467    #endif
468    
469    #ifdef ALLOW_RELAXSST_CONTROL
470              ivartype = 30
471              write(weighttype(1:80),'(80a)') ' '
472              write(weighttype(1:80),'(a)') "wrelaxsst"
473              call ctrl_set_pack_xy(
474         &         cunit, ivartype, fname_relaxsst(ictrlgrad), "maskCtrlC",
475         &         weighttype, lxxadxx, mythid)
476    #endif
477    
478    #ifdef ALLOW_RELAXSSS_CONTROL
479              ivartype = 31
480              write(weighttype(1:80),'(80a)') ' '
481              write(weighttype(1:80),'(a)') "wrelaxsss"
482              call ctrl_set_pack_xy(
483         &         cunit, ivartype, fname_relaxsss(ictrlgrad), "maskCtrlC",
484         &         weighttype, lxxadxx, mythid)
485    #endif
486    
487    #ifdef ALLOW_TR10_CONTROL
488              ivartype = 32
489              write(weighttype(1:80),'(80a)') ' '
490              write(weighttype(1:80),'(a)') "wtr1"
491              call ctrl_set_pack_xyz(
492         &         cunit, ivartype, fname_tr1(ictrlgrad), "maskCtrlC",
493         &         weighttype, wunit, lxxadxx, mythid)
494  #endif  #endif
495    
496            close ( cunit )            close ( cunit )
497    
498            _END_MASTER( mythid )
499    
500    #endif /* EXCLUDE_CTRL_PACK */
501    
502        return        return
503        end        end
504    
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.21
  ViewVC Help
Powered by ViewVC 1.1.22