/[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.19 by heimbach, Thu Apr 7 23:38:43 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_uwind_file, fname_uwind, mythid)
116          call ctrl_set_fname(xx_vwind_file, fname_vwind, mythid)
117          call ctrl_set_fname(xx_obcsn_file, fname_obcsn, mythid)
118          call ctrl_set_fname(xx_obcss_file, fname_obcss, mythid)
119          call ctrl_set_fname(xx_obcsw_file, fname_obcsw, mythid)
120          call ctrl_set_fname(xx_obcse_file, fname_obcse, mythid)
121          call ctrl_set_fname(xx_diffkr_file, fname_diffkr, mythid)
122          call ctrl_set_fname(xx_kapgm_file, fname_kapgm, mythid)
123          call ctrl_set_fname(xx_tr1_file, fname_tr1, mythid)
124          call ctrl_set_fname(xx_sst_file, fname_sst, mythid)
125          call ctrl_set_fname(xx_sss_file, fname_sss, mythid)
126          call ctrl_set_fname(xx_hfacc_file, fname_hfacc, mythid)
127          call ctrl_set_fname(xx_efluxy_file, fname_efluxy, mythid)
128          call ctrl_set_fname(xx_efluxp_file, fname_efluxp, mythid)
129          call ctrl_set_fname(xx_bottomdrag_file, fname_bottomdrag, mythid)
130          call ctrl_set_fname(xx_edtaux_file, fname_edtaux, mythid)
131          call ctrl_set_fname(xx_edtauy_file, fname_edtauy, mythid)
132          call ctrl_set_fname(xx_uvel_file, fname_uvel, mythid)
133          call ctrl_set_fname(xx_vvel_file, fname_vvel, mythid)
134          call ctrl_set_fname(xx_etan_file, fname_etan, mythid)
135          call ctrl_set_fname(xx_relaxsst_file, fname_relaxsst, mythid)
136          call ctrl_set_fname(xx_relaxsss_file, fname_relaxsss, mythid)
137    
138  c--   Only the master thread will do I/O.  c--   Only the master thread will do I/O.
139        _BEGIN_MASTER( mythid )        _BEGIN_MASTER( mythid )
140    
141  c--   read global mask file        if ( first ) then
142            call MDSREADFIELD_3D_GL( "hFacC",  c     >>> Initialise control vector for optimcycle=0 <<<
143       &                           prec, 'RL', Nr, globmsk,            lxxadxx   = .TRUE.
144       &                           1,  mythid)            ictrlgrad = 1
145              fcloc     = fmin
146              write(cfile(1:128),'(4a,i4.4)')
147  c     >>> Write control vector <<<       &         ctrlname(1:9),'_',yctrlid(1:10),
148         &         yctrlpospack, optimcycle
149            call mdsfindunit( cunit, mythid )            print *, 'ph-pack: packing ', ctrlname(1:9)
150            write(cfile(1:128),'(2a,i4.4)')        else
151       &      ctrlname(1:9),'.opt',  c     >>> Write gradient vector <<<
152       &      optimcycle            lxxadxx   = .FALSE.
153              ictrlgrad = 2
154            open( cunit, file   = cfile,            fcloc     = fc
155       &                 status = 'unknown',            write(cfile(1:128),'(4a,i4.4)')
156       &                 form   = 'unformatted',       &         costname(1:9),'_',yctrlid(1:10),
157       &                 access = 'sequential'   )       &         yctrlpospack, optimcycle
158              print *, 'ph-pack: packing ', costname(1:9)
159           endif
160    
161           call mdsfindunit( cunit, mythid )
162           open( cunit, file   = cfile,
163         &      status = 'unknown',
164         &      form   = 'unformatted',
165         &      access  = 'sequential'   )
166    
167  c--       Header information.  c--       Header information.
             
168            write(cunit) nvartype            write(cunit) nvartype
169            write(cunit) nvarlength            write(cunit) nvarlength
170            write(cunit) expId            write(cunit) yctrlid
171            write(cunit) optimCycle            write(cunit) optimCycle
172            write(cunit) tmpvar            write(cunit) fc
173            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)  
174            write(cunit) 1            write(cunit) 1
175    C     place holder of obsolete variable jG
176            write(cunit) 1            write(cunit) 1
177            k = 1            write(cunit) nsx
178             cbuffindex = 0            write(cunit) nsy
179              do jp = 1,nPy            write(cunit) (nWetcGlobal(k), k=1,nr)
180               do bj = jtlo,jthi            write(cunit) (nWetsGlobal(k), k=1,nr)
181                do j = jmin,jmax            write(cunit) (nWetwGlobal(k), k=1,nr)
182                 do ip = 1,nPx  #ifdef ALLOW_CTRL_WETV
183                  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)  
184  #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  
185    
186    #ifdef ALLOW_OBCSN_CONTROL
187              write(cunit) ((nWetobcsnGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
188  #endif  #endif
189    #ifdef ALLOW_OBCSS_CONTROL
190  #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)  
191  #endif  #endif
192                      endif  #ifdef ALLOW_OBCSW_CONTROL
193                   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  
   
194  #endif  #endif
195    #ifdef ALLOW_OBCSE_CONTROL
196  #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)  
197  #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)  
198            write(cunit) (ncvarindex(i), i=1,maxcvars)            write(cunit) (ncvarindex(i), i=1,maxcvars)
199            write(cunit) (ncvarrecs(i),  i=1,maxcvars)            write(cunit) (ncvarrecs(i),  i=1,maxcvars)
200            write(cunit) (nx,  i=1,maxcvars)            write(cunit) (ncvarxmax(i),  i=1,maxcvars)
201            write(cunit) (ny,  i=1,maxcvars)            write(cunit) (ncvarymax(i),  i=1,maxcvars)
202            write(cunit) (ncvarnrmax(i), i=1,maxcvars)            write(cunit) (ncvarnrmax(i), i=1,maxcvars)
203            write(cunit) (ncvargrd(i),   i=1,maxcvars)            write(cunit) (ncvargrd(i),   i=1,maxcvars)
204            write(cunit)            write(cunit)
205    
206  #ifdef ALLOW_THETA0_CONTROL  #ifdef ALLOW_THETA0_CONTROL
207              ivartype = 1
208            il=ilnblnk( xx_theta_file)            write(weighttype(1:80),'(80a)') ' '
209            write(fname(1:80),'(80a)') ' '            write(weighttype(1:80),'(a)') "wtheta"
210            write(fname(1:80),'(3a,i10.10)')            call ctrl_set_pack_xyz(
211       &         yadmark,xx_theta_file(1:il),'.',optimcycle       &         cunit, ivartype, fname_theta(ictrlgrad), "maskCtrlC",
212         &         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  
   
213  #endif  #endif
214    
215  #ifdef ALLOW_SALT0_CONTROL  #ifdef ALLOW_SALT0_CONTROL
216              ivartype = 2
217            il=ilnblnk( xx_salt_file)            write(weighttype(1:80),'(80a)') ' '
218            write(fname(1:80),'(80a)') ' '            write(weighttype(1:80),'(a)') "wsalt"
219            write(fname(1:80),'(3a,i10.10)')            call ctrl_set_pack_xyz(
220       &         yadmark,xx_salt_file(1:il),'.',optimcycle       &         cunit, ivartype, fname_salt(ictrlgrad), "maskCtrlC",
221         &         weighttype, wsalt, lxxadxx, mythid)
222            call MDSREADFIELD_3D_GL( fname,  #endif
223       &                          prec, 'RL', Nr,  
224       &                          globfld3d,  #if (defined (ALLOW_HFLUX_CONTROL) || \
225       &                          1,  mythid)       defined (ALLOW_HFLUX0_CONTROL))
226                        ivartype = 3
227            write(cunit) ncvarindex(2)            write(weighttype(1:80),'(80a)') ' '
228            write(cunit) 1            write(weighttype(1:80),'(a)') "whflux"
229            write(cunit) 1            call ctrl_set_pack_xy(
230            do k = 1,nr       &         cunit, ivartype, fname_hflux(ictrlgrad), "maskCtrlC",
231             cbuffindex = 0       &         weighttype, lxxadxx, mythid)
232              do jp = 1,nPy  #endif
233               do bj = jtlo,jthi  
234                do j = jmin,jmax  #if (defined (ALLOW_SFLUX_CONTROL) || \
235                 do ip = 1,nPx       defined (ALLOW_SFLUX0_CONTROL))
236                  do bi = itlo,ithi            ivartype = 4
237                   do i = imin,imax            write(weighttype(1:80),'(80a)') ' '
238                      if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then            write(weighttype(1:80),'(a)') "wsflux"
239                         cbuffindex = cbuffindex + 1            call ctrl_set_pack_xy(
240  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO       &         cunit, ivartype, fname_sflux(ictrlgrad), "maskCtrlC",
241                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)       &         weighttype, lxxadxx, mythid)
242       &                      * sqrt(wsalt(k,bi,bj))  #endif
243  #else  
244                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  #if (defined (ALLOW_USTRESS_CONTROL) || \
245  #endif       defined (ALLOW_TAUU0_CONTROL))
246                      endif            ivartype = 5
247                   enddo            write(weighttype(1:80),'(80a)') ' '
248                  enddo            write(weighttype(1:80),'(a)') "wtauu"
249                 enddo            call ctrl_set_pack_xy(
250                enddo       &         cunit, ivartype, fname_tauu(ictrlgrad), "maskCtrlW",
251               enddo       &         weighttype, lxxadxx, mythid)
252              enddo  #endif
253  c     --> check cbuffindex.  
254              if ( cbuffindex .gt. 0) then  #if (defined (ALLOW_VSTRESS_CONTROL) || \
255                 write(cunit) cbuffindex       defined (ALLOW_TAUV0_CONTROL))
256                 write(cunit) k            ivartype = 6
257                 write(cunit) (cbuff(ii), ii=1,cbuffindex)            write(weighttype(1:80),'(80a)') ' '
258              endif            write(weighttype(1:80),'(a)') "wtauv"
259           enddo            call ctrl_set_pack_xy(
260         &         cunit, ivartype, fname_tauv(ictrlgrad), "maskCtrlS",
261  #endif       &         weighttype, lxxadxx, mythid)
262    #endif
263    
264  #ifdef ALLOW_HFLUX0_CONTROL  #ifdef ALLOW_ATEMP_CONTROL
265              ivartype = 7
266            il=ilnblnk( xx_hflux_file)            write(weighttype(1:80),'(80a)') ' '
267            write(fname(1:80),'(80a)') ' '            write(weighttype(1:80),'(a)') "watemp"
268            write(fname(1:80),'(3a,i10.10)')            call ctrl_set_pack_xy(
269       &         yadmark,xx_hflux_file(1:il),'.',optimcycle       &         cunit, ivartype, fname_atemp(ictrlgrad), "maskCtrlC",
270  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO       &         weighttype, lxxadxx, mythid)
271            call MDSREADFIELD_2D_GL( "whflux",  #endif
272       &                          prec, 'RL', 1,  
273       &                          globfld2d,  #ifdef ALLOW_AQH_CONTROL
274       &                          1,  mythid)            ivartype = 8
275  #endif            write(weighttype(1:80),'(80a)') ' '
276            call MDSREADFIELD_2D_GL( fname,            write(weighttype(1:80),'(a)') "waqh"
277       &                          prec, 'RL', 1,            call ctrl_set_pack_xy(
278       &                          globfld3d(1,1,1,1,1,1,1),       &         cunit, ivartype, fname_aqh(ictrlgrad), "maskCtrlC",
279       &                          1,  mythid)       &         weighttype, lxxadxx, mythid)
280    #endif
281            write(cunit) ncvarindex(3)  
282            write(cunit) 1  #ifdef ALLOW_UWIND_CONTROL
283            write(cunit) 1            ivartype = 9
284            k = 1            write(weighttype(1:80),'(80a)') ' '
285             cbuffindex = 0            write(weighttype(1:80),'(a)') "wuwind"
286              do jp = 1,nPy            call ctrl_set_pack_xy(
287               do bj = jtlo,jthi       &         cunit, ivartype, fname_uwind(ictrlgrad), "maskCtrlW",
288                do j = jmin,jmax       &         weighttype, lxxadxx, mythid)
289                 do ip = 1,nPx  #endif
290                  do bi = itlo,ithi  
291                   do i = imin,imax  #ifdef ALLOW_VWIND_CONTROL
292                      if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then            ivartype = 10
293                         cbuffindex = cbuffindex + 1            write(weighttype(1:80),'(80a)') ' '
294  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO            write(weighttype(1:80),'(a)') "wvwind"
295                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)            call ctrl_set_pack_xy(
296       &                      * sqrt(globfld2d(i,bi,ip,j,bj,jp))       &         cunit, ivartype, fname_vwind(ictrlgrad), "maskCtrlS",
297  #else       &         weighttype, lxxadxx, mythid)
298                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  #endif
299  #endif  
300                      endif  #ifdef ALLOW_OBCSN_CONTROL
301                   enddo            ivartype = 11
302                  enddo            write(weighttype(1:80),'(80a)') ' '
303                 enddo            write(weighttype(1:80),'(a)') "wobcsn"
304                enddo            call ctrl_set_pack_xz(
305               enddo       &         cunit, ivartype, fname_obcsn(ictrlgrad), "maskobcsn",
306              enddo       &         weighttype, wobcsn, lxxadxx, mythid)
307  c     --> check cbuffindex.  #endif
308              if ( cbuffindex .gt. 0) then  
309                 write(cunit) cbuffindex  #ifdef ALLOW_OBCSS_CONTROL
310                 write(cunit) k            ivartype = 12
311                 write(cunit) (cbuff(ii), ii=1,cbuffindex)            write(weighttype(1:80),'(80a)') ' '
312              endif            write(weighttype(1:80),'(a)') "wobcss"
313              call ctrl_set_pack_xz(
314  #endif       &         cunit, ivartype, fname_obcss(ictrlgrad), "maskobcss",
315         &         weighttype, wobcss, lxxadxx, mythid)
316  #ifdef ALLOW_SFLUX0_CONTROL  #endif
317    
318            il=ilnblnk( xx_sflux_file)  #ifdef ALLOW_OBCSW_CONTROL
319            write(fname(1:80),'(80a)') ' '            ivartype = 13
320            write(fname(1:80),'(3a,i10.10)')            write(weighttype(1:80),'(80a)') ' '
321       &         yadmark,xx_sflux_file(1:il),'.',optimcycle            write(weighttype(1:80),'(a)') "wobcsw"
322  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO            call ctrl_set_pack_yz(
323            call MDSREADFIELD_2D_GL( "wsflux",       &         cunit, ivartype, fname_obcsw(ictrlgrad), "maskobcsw",
324       &                          prec, 'RL', 1,       &         weighttype, wobcsw, lxxadxx, mythid)
325       &                          globfld2d,  #endif
326       &                          1,  mythid)  
327  #endif  #ifdef ALLOW_OBCSE_CONTROL
328            call MDSREADFIELD_2D_GL( fname,            ivartype = 14
329       &                          prec, 'RL', 1,            write(weighttype(1:80),'(80a)') ' '
330       &                          globfld3d(1,1,1,1,1,1,1),            write(weighttype(1:80),'(a)') "wobcse"
331       &                          1,  mythid)            call ctrl_set_pack_yz(
332         &         cunit, ivartype, fname_obcse(ictrlgrad), "maskobcse",
333            write(cunit) ncvarindex(4)       &         weighttype, wobcse, lxxadxx, mythid)
334            write(cunit) 1  #endif
335            write(cunit) 1  
336            k = 1  #ifdef ALLOW_DIFFKR_CONTROL
337             cbuffindex = 0            ivartype = 15
338              do jp = 1,nPy            write(weighttype(1:80),'(80a)') ' '
339               do bj = jtlo,jthi            write(weighttype(1:80),'(a)') "wdiffkr"
340                do j = jmin,jmax            call ctrl_set_pack_xyz(
341                 do ip = 1,nPx       &         cunit, ivartype, fname_diffkr(ictrlgrad), "maskCtrlC",
342                  do bi = itlo,ithi       &         weighttype, wunit, lxxadxx, mythid)
343                   do i = imin,imax  #endif
344                      if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
345                         cbuffindex = cbuffindex + 1  #ifdef ALLOW_KAPGM_CONTROL
346  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO            ivartype = 16
347                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)            write(weighttype(1:80),'(80a)') ' '
348       &                      * sqrt(globfld2d(i,bi,ip,j,bj,jp))            write(weighttype(1:80),'(a)') "wkapgm"
349  #else            call ctrl_set_pack_xyz(
350                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)       &         cunit, ivartype, fname_kapgm(ictrlgrad), "maskCtrlC",
351  #endif       &         weighttype, wunit, lxxadxx, mythid)
352                      endif  #endif
353                   enddo  
354                  enddo  #ifdef ALLOW_TR10_CONTROL
355                 enddo            ivartype = 17
356                enddo            write(weighttype(1:80),'(80a)') ' '
357               enddo            write(weighttype(1:80),'(a)') "wtr1"
358              enddo            call ctrl_set_pack_xyz(
359  c     --> check cbuffindex.       &         cunit, ivartype, fname_tr1(ictrlgrad), "maskCtrlC",
360              if ( cbuffindex .gt. 0) then       &         weighttype, wunit, 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  
   
361  #endif  #endif
362    
363  #ifdef ALLOW_SST0_CONTROL  #ifdef ALLOW_SST0_CONTROL
364              ivartype = 18
365            il=ilnblnk( xx_sst_file)            write(weighttype(1:80),'(80a)') ' '
366            write(fname(1:80),'(80a)') ' '            write(weighttype(1:80),'(a)') "wsst0"
367            write(fname(1:80),'(3a,i10.10)')            call ctrl_set_pack_xy(
368       &         yadmark,xx_sst_file(1:il),'.',optimcycle       &         cunit, ivartype, fname_sst(ictrlgrad), "maskCtrlC",
369  #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  
   
370  #endif  #endif
371    
372  #ifdef ALLOW_SSS0_CONTROL  #ifdef ALLOW_SSS0_CONTROL
373              ivartype = 19
374            il=ilnblnk( xx_sss_file)            write(weighttype(1:80),'(80a)') ' '
375            write(fname(1:80),'(80a)') ' '            write(weighttype(1:80),'(a)') "wsss0"
376            write(fname(1:80),'(3a,i10.10)')            call ctrl_set_pack_xy(
377       &         yadmark,xx_sss_file(1:il),'.',optimcycle       &         cunit, ivartype, fname_sss(ictrlgrad), "maskCtrlC",
378  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO       &         weighttype, lxxadxx, mythid)
379            call MDSREADFIELD_2D_GL( "wsss",  #endif
380       &                          prec, 'RL', 1,  
381       &                          globfld2d,  #ifdef ALLOW_HFACC_CONTROL
382       &                          1,  mythid)            ivartype = 20
383  #endif            write(weighttype(1:80),'(80a)') ' '
384            call MDSREADFIELD_2D_GL( fname,            write(weighttype(1:80),'(a)') "whfacc"
385       &                          prec, 'RL', 1,  # ifdef ALLOW_HFACC3D_CONTROL
386       &                          globfld3d(1,1,1,1,1,1,1),            call ctrl_set_pack_xyz(
387       &                          1,  mythid)       &         cunit, ivartype, fname_hfacc(ictrlgrad), "maskCtrlC",
388         &         weighttype, wunit, lxxadxx, mythid)
389            write(cunit) ncvarindex(8)  # else
390            write(cunit) 1            call ctrl_set_pack_xy(
391            write(cunit) 1       &         cunit, ivartype, fname_hfacc(ictrlgrad), "maskCtrlC",
392            k = 1       &         weighttype, lxxadxx, mythid)
393             cbuffindex = 0  # endif
394              do jp = 1,nPy  #endif
395               do bj = jtlo,jthi  
396                do j = jmin,jmax  #ifdef ALLOW_EFLUXY0_CONTROL
397                 do ip = 1,nPx            ivartype = 21
398                  do bi = itlo,ithi            write(weighttype(1:80),'(80a)') ' '
399                   do i = imin,imax            write(weighttype(1:80),'(a)') "wefluxy0"
400                      if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then            call ctrl_set_pack_xyz(
401                         cbuffindex = cbuffindex + 1       &         cunit, ivartype, fname_efluxy(ictrlgrad), "maskCtrlS",
402  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO       &         weighttype, wunit, lxxadxx, mythid)
403                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  #endif
404       &                      * sqrt(globfld2d(i,bi,ip,j,bj,jp))  
405  #else  #ifdef ALLOW_EFLUXP0_CONTROL
406                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)            ivartype = 22
407  #endif            write(weighttype(1:80),'(80a)') ' '
408                      endif            write(weighttype(1:80),'(a)') "wefluxp0"
409                   enddo            call ctrl_set_pack_xyz(
410                  enddo       &         cunit, ivartype, fname_efluxp(ictrlgrad), "maskhFacV",
411                 enddo       &         weighttype, wunit, lxxadxx, mythid)
412                enddo  #endif
413               enddo  
414              enddo  #ifdef ALLOW_BOTTOMDRAG_CONTROL
415  c     --> check cbuffindex.            ivartype = 23
416              if ( cbuffindex .gt. 0) then            write(weighttype(1:80),'(80a)') ' '
417                 write(cunit) cbuffindex            write(weighttype(1:80),'(a)') "wbottomdrag"
418                 write(cunit) k            call ctrl_set_pack_xy(
419                 write(cunit) (cbuff(ii), ii=1,cbuffindex)       &      cunit, ivartype, fname_bottomdrag(ictrlgrad), "maskCtrlC",
420              endif       &      weighttype, lxxadxx, mythid)
421    #endif
422    
423    #ifdef ALLOW_EDTAUX_CONTROL
424              ivartype = 25
425              write(weighttype(1:80),'(80a)') ' '
426              write(weighttype(1:80),'(a)') "wedtaux"
427              call ctrl_set_pack_xyz(
428         &         cunit, ivartype, fname_edtaux(ictrlgrad), "maskCtrlW",
429         &         weighttype, wunit, lxxadxx, mythid)
430    #endif
431    
432    #ifdef ALLOW_EDTAUY_CONTROL
433              ivartype = 26
434              write(weighttype(1:80),'(80a)') ' '
435              write(weighttype(1:80),'(a)') "wedtauy"
436              call ctrl_set_pack_xyz(
437         &         cunit, ivartype, fname_edtauy(ictrlgrad), "maskCtrlS",
438         &         weighttype, wunit, lxxadxx, mythid)
439    #endif
440    
441    #ifdef ALLOW_UVEL0_CONTROL
442              ivartype = 27
443              write(weighttype(1:80),'(80a)') ' '
444              write(weighttype(1:80),'(a)') "wuvel"
445              call ctrl_set_pack_xyz(
446         &         cunit, ivartype, fname_uvel(ictrlgrad), "maskCtrlW",
447         &         weighttype, wunit, lxxadxx, mythid)
448    #endif
449    
450    #ifdef ALLOW_VVEL0_CONTROL
451              ivartype = 28
452              write(weighttype(1:80),'(80a)') ' '
453              write(weighttype(1:80),'(a)') "wvvel"
454              call ctrl_set_pack_xyz(
455         &         cunit, ivartype, fname_vvel(ictrlgrad), "maskCtrlS",
456         &         weighttype, wunit, lxxadxx, mythid)
457    #endif
458    
459    #ifdef ALLOW_ETAN0_CONTROL
460              ivartype = 29
461              write(weighttype(1:80),'(80a)') ' '
462              write(weighttype(1:80),'(a)') "wetan"
463              call ctrl_set_pack_xy(
464         &         cunit, ivartype, fname_etan(ictrlgrad), "maskCtrlC",
465         &         weighttype, lxxadxx, mythid)
466    #endif
467    
468    #ifdef ALLOW_RELAXSST_CONTROL
469              ivartype = 30
470              write(weighttype(1:80),'(80a)') ' '
471              write(weighttype(1:80),'(a)') "wrelaxsst"
472              call ctrl_set_pack_xy(
473         &         cunit, ivartype, fname_relaxsst(ictrlgrad), "maskCtrlC",
474         &         weighttype, lxxadxx, mythid)
475    #endif
476    
477    #ifdef ALLOW_RELAXSSS_CONTROL
478              ivartype = 31
479              write(weighttype(1:80),'(80a)') ' '
480              write(weighttype(1:80),'(a)') "wrelaxsss"
481              call ctrl_set_pack_xy(
482         &         cunit, ivartype, fname_relaxsss(ictrlgrad), "maskCtrlC",
483         &         weighttype, lxxadxx, mythid)
484  #endif  #endif
485    
486            close ( cunit )            close ( cunit )
487    
488            _END_MASTER( mythid )
489    
490    #endif /* EXCLUDE_CTRL_PACK */
491    
492        return        return
493        end        end
494    
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.19
  ViewVC Help
Powered by ViewVC 1.1.22