/[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.4 by heimbach, Fri Sep 28 15:15:55 2001 UTC revision 1.30 by heimbach, Thu Jun 21 04:06:21 2007 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  CBOP        subroutine ctrl_pack( first, mythid )
8  C     !ROUTINE: ctrl_pack  
9  C     !INTERFACE:  c     ==================================================================
10        subroutine ctrl_pack( myiter, mytime, mythid )  c     SUBROUTINE ctrl_pack
11    c     ==================================================================
12  C     !DESCRIPTION: \bv  c
13  c     *=================================================================  c     o Compress the control vector such that only ocean points are
14  c     | SUBROUTINE ctrl_pack  c       written to file.
15  c     | Pack the control vector  c
16  c     | * All control variable and adjoint variable fields are  c     started: Christian Eckert eckert@mit.edu  10-Mar=2000
17  c     |   read from disk.  c
18  c     | * Wet points are extracted, and elements are  c     changed: Patrick Heimbach heimbach@mit.edu 06-Jun-2000
19  c     |   normalized (optional)  c              - Transferred some filename declarations
20  c     | * A single control vector containing only (normalized  c                from here to namelist in ctrl_init
21  c     |   wet points is written to file.  c  
22  c     *=================================================================  c              Patrick Heimbach heimbach@mit.edu 16-Jun-2000
23  C     \ev  c              - single file name convention with or without
24    c                ALLOW_ECCO_OPTIMIZATION
25    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
31    c     ==================================================================
32    c     SUBROUTINE ctrl_pack
33    c     ==================================================================
34    
 C     !USES:  
35        implicit none        implicit none
36    
37  c     == global variables ==  c     == global variables ==
38    
39  #include "EEPARAMS.h"  #include "EEPARAMS.h"
40  #include "SIZE.h"  #include "SIZE.h"
41  #include "PARAMS.h"  #include "PARAMS.h"
42  #include "GRID.h"  #include "GRID.h"
43    
44  #include "ctrl.h"  #include "ctrl.h"
 #include "cost.h"  
45  #include "optim.h"  #include "optim.h"
46    
47  C     !INPUT/OUTPUT PARAMETERS:  #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        integer myiter  
58        _RL     mytime        logical first
59        integer mythid        integer mythid
60    
61  C     !LOCAL VARIABLES:  #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  
       integer cbuffindex  
       integer cunit  
       integer prec  
73    
74        logical doglobalread        logical doglobalread
75        logical ladinit        logical ladinit
76          integer cbuffindex
77        _RL     cbuff( snx*nsx*npx*sny*nsy*npy )        logical lxxadxx
78        _RL     globfld3d( snx,nsx,npx,sny,nsy,npy,nr )        
79        _RL     globfld2d( snx,nsx,npx,sny,nsy,npy )        integer cunit
80        _RL     globmsk( snx,nsx,npx,sny,nsy,npy,nr )        integer ictrlgrad
       _RL     tmpvar  
81    
82        character*(128) cfile        character*(128) cfile
83        character*( 80) fname        character*( 80) weighttype
84    
85  c     == external ==  c     == external ==
86    
87        integer  ilnblnk        integer  ilnblnk
88        external ilnblnk        external ilnblnk
89    
90  c     == end of interface ==  c     == end of interface ==
 CEOP  
   
       prec           = precFloat64  
       tmpvar         = -9999. _d 0  
91    
92        jtlo = 1  #ifndef ALLOW_ECCO_OPTIMIZATION
93        jthi = nsy        fmin       = 0. _d 0
94        itlo = 1  #endif
       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 92  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_swflux_file, fname_swflux, mythid)
117          call ctrl_set_fname(xx_swdown_file, fname_swdown, mythid)
118          call ctrl_set_fname(xx_lwflux_file, fname_lwflux, mythid)
119          call ctrl_set_fname(xx_lwdown_file, fname_lwdown, mythid)
120          call ctrl_set_fname(xx_evap_file, fname_evap, mythid)
121          call ctrl_set_fname(xx_snowprecip_file, fname_snowprecip, mythid)
122          call ctrl_set_fname(xx_apressure_file, fname_apressure, mythid)
123          call ctrl_set_fname(xx_runoff_file, fname_runoff, mythid)
124    
125          call ctrl_set_fname(xx_uwind_file, fname_uwind, mythid)
126          call ctrl_set_fname(xx_vwind_file, fname_vwind, mythid)
127          call ctrl_set_fname(xx_obcsn_file, fname_obcsn, mythid)
128          call ctrl_set_fname(xx_obcss_file, fname_obcss, mythid)
129          call ctrl_set_fname(xx_obcsw_file, fname_obcsw, mythid)
130          call ctrl_set_fname(xx_obcse_file, fname_obcse, mythid)
131          call ctrl_set_fname(xx_diffkr_file, fname_diffkr, mythid)
132          call ctrl_set_fname(xx_kapgm_file, fname_kapgm, mythid)
133          call ctrl_set_fname(xx_tr1_file, fname_tr1, mythid)
134          call ctrl_set_fname(xx_sst_file, fname_sst, mythid)
135          call ctrl_set_fname(xx_sss_file, fname_sss, mythid)
136          call ctrl_set_fname(xx_depth_file, fname_depth, mythid)
137          call ctrl_set_fname(xx_efluxy_file, fname_efluxy, mythid)
138          call ctrl_set_fname(xx_efluxp_file, fname_efluxp, mythid)
139          call ctrl_set_fname(xx_bottomdrag_file, fname_bottomdrag, mythid)
140          call ctrl_set_fname(xx_edtaux_file, fname_edtaux, mythid)
141          call ctrl_set_fname(xx_edtauy_file, fname_edtauy, mythid)
142          call ctrl_set_fname(xx_uvel_file, fname_uvel, mythid)
143          call ctrl_set_fname(xx_vvel_file, fname_vvel, mythid)
144          call ctrl_set_fname(xx_etan_file, fname_etan, mythid)
145          call ctrl_set_fname(xx_relaxsst_file, fname_relaxsst, mythid)
146          call ctrl_set_fname(xx_relaxsss_file, fname_relaxsss, mythid)
147          call ctrl_set_fname(xx_siarea_file, fname_siarea, mythid)
148          call ctrl_set_fname(xx_siheff_file, fname_siheff, mythid)
149          call ctrl_set_fname(xx_sihsnow_file, fname_sihsnow, mythid)
150    
151  c--   Only the master thread will do I/O.  c--   Only the master thread will do I/O.
152        _BEGIN_MASTER( mythid )        _BEGIN_MASTER( mythid )
153    
154  c--   read global mask file        if ( first ) then
155            call MDSREADFIELD_3D_GL( "hFacC",  c     >>> Initialise control vector for optimcycle=0 <<<
156       &                           prec, 'RL', Nr, globmsk,            lxxadxx   = .TRUE.
157       &                           1,  mythid)            ictrlgrad = 1
158              fcloc     = fmin
159              write(cfile(1:128),'(4a,i4.4)')
160  c     >>> Write control vector <<<       &         ctrlname(1:9),'_',yctrlid(1:10),
161         &         yctrlpospack, optimcycle
162            call mdsfindunit( cunit, mythid )            print *, 'ph-pack: packing ', ctrlname(1:9)
163            write(cfile(1:128),'(2a,i4.4)')        else
164       &      ctrlname(1:9),'.opt',  c     >>> Write gradient vector <<<
165       &      optimcycle            lxxadxx   = .FALSE.
166              ictrlgrad = 2
167            open( cunit, file   = cfile,            fcloc     = fc
168       &                 status = 'unknown',            write(cfile(1:128),'(4a,i4.4)')
169       &                 form   = 'unformatted',       &         costname(1:9),'_',yctrlid(1:10),
170       &                 access = 'sequential'   )       &         yctrlpospack, optimcycle
171              print *, 'ph-pack: packing ', costname(1:9)
172           endif
173    
174           call mdsfindunit( cunit, mythid )
175           open( cunit, file   = cfile,
176         &      status = 'unknown',
177         &      form   = 'unformatted',
178         &      access  = 'sequential'   )
179    
180  c--       Header information.  c--       Header information.
             
181            write(cunit) nvartype            write(cunit) nvartype
182            write(cunit) nvarlength            write(cunit) nvarlength
183            write(cunit) expId            write(cunit) yctrlid
184            write(cunit) optimCycle            write(cunit) optimCycle
185            write(cunit) tmpvar            write(cunit) fc
186            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_TR10_CONTROL  
   
           il=ilnblnk( xx_tr1_file)  
           write(fname(1:80),'(80a)') ' '  
           write(fname(1:80),'(2a,i10.10)')  
      &         xx_tr1_file(1:il),'.',optimcycle  
           call MDSREADFIELD_3D_GL( fname,  
      &                          prec, 'RL', Nr, globfld3d,  
      &                          1,  mythid)  
   
           write(cunit) ncvarindex(9)  
           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)  
 cph     &                      * sqrt(wtr1(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)  
           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_SST0_CONTROL  
   
           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)  
187            write(cunit) 1            write(cunit) 1
188    C     place holder of obsolete variable jG
189            write(cunit) 1            write(cunit) 1
190            k = 1            write(cunit) nsx
191             cbuffindex = 0            write(cunit) nsy
192              do jp = 1,nPy            write(cunit) (nWetcGlobal(k), k=1,nr)
193               do bj = jtlo,jthi            write(cunit) (nWetsGlobal(k), k=1,nr)
194                do j = jmin,jmax            write(cunit) (nWetwGlobal(k), k=1,nr)
195                 do ip = 1,nPx  #ifdef ALLOW_CTRL_WETV
196                  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)  
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  
198    
199    #ifdef ALLOW_OBCSN_CONTROL
200              write(cunit) ((nWetobcsnGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
201  #endif  #endif
202    #ifdef ALLOW_OBCSS_CONTROL
203  #ifdef ALLOW_SSS0_CONTROL            write(cunit) ((nWetobcssGlo(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)  
 #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  
   
204  #endif  #endif
205    #ifdef ALLOW_OBCSW_CONTROL
206  #ifdef ALLOW_DIFFKR_CONTROL            write(cunit) ((nWetobcswGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
   
           il=ilnblnk( xx_diffkr_file)  
           write(fname(1:80),'(80a)') ' '  
           write(fname(1:80),'(2a,i10.10)')  
      &         xx_diffkr_file(1:il),'.',optimcycle  
           call MDSREADFIELD_3D_GL( fname,  
      &                          prec, 'RL', Nr, globfld3d,  
      &                          1,  mythid)  
   
           write(cunit) ncvarindex(15)  
           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)  
 cph     &                      * sqrt(wdiffkr(k,bi,bj))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
207  #endif  #endif
208                      endif  #ifdef ALLOW_OBCSE_CONTROL
209                   enddo            write(cunit) ((nWetobcseGlo(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  
          enddo  
               
210  #endif  #endif
   
 #ifdef ALLOW_KAPGM_CONTROL  
   
           il=ilnblnk( xx_kapgm_file)  
           write(fname(1:80),'(80a)') ' '  
           write(fname(1:80),'(2a,i10.10)')  
      &         xx_kapgm_file(1:il),'.',optimcycle  
           call MDSREADFIELD_3D_GL( fname,  
      &                          prec, 'RL', Nr, globfld3d,  
      &                          1,  mythid)  
   
           write(cunit) ncvarindex(16)  
           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)  
 cph     &                      * sqrt(wkapgm(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  
   
           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)  
211            write(cunit) (ncvarindex(i), i=1,maxcvars)            write(cunit) (ncvarindex(i), i=1,maxcvars)
212            write(cunit) (ncvarrecs(i),  i=1,maxcvars)            write(cunit) (ncvarrecs(i),  i=1,maxcvars)
213            write(cunit) (nx,  i=1,maxcvars)            write(cunit) (ncvarxmax(i),  i=1,maxcvars)
214            write(cunit) (ny,  i=1,maxcvars)            write(cunit) (ncvarymax(i),  i=1,maxcvars)
215            write(cunit) (ncvarnrmax(i), i=1,maxcvars)            write(cunit) (ncvarnrmax(i), i=1,maxcvars)
216            write(cunit) (ncvargrd(i),   i=1,maxcvars)            write(cunit) (ncvargrd(i),   i=1,maxcvars)
217            write(cunit)            write(cunit)
218    
219  #ifdef ALLOW_THETA0_CONTROL  #ifdef ALLOW_THETA0_CONTROL
220              ivartype = 1
221            il=ilnblnk( xx_theta_file)            write(weighttype(1:80),'(80a)') ' '
222            write(fname(1:80),'(80a)') ' '            write(weighttype(1:80),'(a)') "wthetaLev"
223            write(fname(1:80),'(3a,i10.10)')            call ctrl_set_pack_xyz(
224       &         yadmark,xx_theta_file(1:il),'.',optimcycle       &         cunit, ivartype, fname_theta(ictrlgrad), "maskCtrlC",
225         &         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  
   
226  #endif  #endif
227    
228  #ifdef ALLOW_SALT0_CONTROL  #ifdef ALLOW_SALT0_CONTROL
229              ivartype = 2
230            il=ilnblnk( xx_salt_file)            write(weighttype(1:80),'(80a)') ' '
231            write(fname(1:80),'(80a)') ' '            write(weighttype(1:80),'(a)') "wsaltLev"
232            write(fname(1:80),'(3a,i10.10)')            call ctrl_set_pack_xyz(
233       &         yadmark,xx_salt_file(1:il),'.',optimcycle       &         cunit, ivartype, fname_salt(ictrlgrad), "maskCtrlC",
234         &         weighttype, wsalt, lxxadxx, mythid)
235            call MDSREADFIELD_3D_GL( fname,  #endif
236       &                          prec, 'RL', Nr,  
237       &                          globfld3d,  #if (defined (ALLOW_HFLUX_CONTROL) || defined (ALLOW_HFLUX0_CONTROL))
238       &                          1,  mythid)            ivartype = 3
239                        write(weighttype(1:80),'(80a)') ' '
240            write(cunit) ncvarindex(2)            write(weighttype(1:80),'(a)') "whflux"
241            write(cunit) 1            call ctrl_set_pack_xy(
242            write(cunit) 1       &         cunit, ivartype, fname_hflux(ictrlgrad), "maskCtrlC",
243            do k = 1,nr       &         weighttype, lxxadxx, mythid)
244             cbuffindex = 0  #endif
245              do jp = 1,nPy  
246               do bj = jtlo,jthi  #if (defined (ALLOW_SFLUX_CONTROL) || defined (ALLOW_SFLUX0_CONTROL))
247                do j = jmin,jmax            ivartype = 4
248                 do ip = 1,nPx            write(weighttype(1:80),'(80a)') ' '
249                  do bi = itlo,ithi            write(weighttype(1:80),'(a)') "wsflux"
250                   do i = imin,imax            call ctrl_set_pack_xy(
251                      if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then       &         cunit, ivartype, fname_sflux(ictrlgrad), "maskCtrlC",
252                         cbuffindex = cbuffindex + 1       &         weighttype, lxxadxx, mythid)
253  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  #endif
254                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
255       &                      * sqrt(wsalt(k,bi,bj))  #if (defined (ALLOW_USTRESS_CONTROL) || defined (ALLOW_TAUU0_CONTROL))
256  #else            ivartype = 5
257                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)            write(weighttype(1:80),'(80a)') ' '
258  #endif            write(weighttype(1:80),'(a)') "wtauu"
259                      endif            call ctrl_set_pack_xy(
260                   enddo       &         cunit, ivartype, fname_tauu(ictrlgrad), "maskCtrlW",
261                  enddo       &         weighttype, lxxadxx, mythid)
262                 enddo  #endif
263                enddo  
264               enddo  #if (defined (ALLOW_VSTRESS_CONTROL) || defined (ALLOW_TAUV0_CONTROL))
265              enddo            ivartype = 6
266  c     --> check cbuffindex.            write(weighttype(1:80),'(80a)') ' '
267              if ( cbuffindex .gt. 0) then            write(weighttype(1:80),'(a)') "wtauv"
268                 write(cunit) cbuffindex            call ctrl_set_pack_xy(
269                 write(cunit) k       &         cunit, ivartype, fname_tauv(ictrlgrad), "maskCtrlS",
270                 write(cunit) (cbuff(ii), ii=1,cbuffindex)       &         weighttype, lxxadxx, mythid)
271              endif  #endif
272           enddo  
273    #ifdef ALLOW_ATEMP_CONTROL
274  #endif            ivartype = 7
275              write(weighttype(1:80),'(80a)') ' '
276  #ifdef ALLOW_TR10_CONTROL            write(weighttype(1:80),'(a)') "watemp"
277              call ctrl_set_pack_xy(
278            il=ilnblnk( xx_tr1_file)       &         cunit, ivartype, fname_atemp(ictrlgrad), "maskCtrlC",
279            write(fname(1:80),'(80a)') ' '       &         weighttype, lxxadxx, mythid)
280            write(fname(1:80),'(3a,i10.10)')  #endif
281       &         yadmark,xx_tr1_file(1:il),'.',optimcycle  
282    #ifdef ALLOW_AQH_CONTROL
283            call MDSREADFIELD_3D_GL( fname,            ivartype = 8
284       &                          prec, 'RL', Nr,            write(weighttype(1:80),'(80a)') ' '
285       &                          globfld3d,            write(weighttype(1:80),'(a)') "waqh"
286       &                          1,  mythid)            call ctrl_set_pack_xy(
287                   &         cunit, ivartype, fname_aqh(ictrlgrad), "maskCtrlC",
288            write(cunit) ncvarindex(9)       &         weighttype, lxxadxx, mythid)
289            write(cunit) 1  #endif
290            write(cunit) 1  
291            do k = 1,nr  #ifdef ALLOW_UWIND_CONTROL
292             cbuffindex = 0            ivartype = 9
293              do jp = 1,nPy            write(weighttype(1:80),'(80a)') ' '
294               do bj = jtlo,jthi            write(weighttype(1:80),'(a)') "wuwind"
295                do j = jmin,jmax            call ctrl_set_pack_xy(
296                 do ip = 1,nPx       &         cunit, ivartype, fname_uwind(ictrlgrad), "maskCtrlC",
297                  do bi = itlo,ithi       &         weighttype, lxxadxx, mythid)
298                   do i = imin,imax  #endif
299                      if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then  
300                         cbuffindex = cbuffindex + 1  #ifdef ALLOW_VWIND_CONTROL
301  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO            ivartype = 10
302                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)            write(weighttype(1:80),'(80a)') ' '
303  cph     &                      * sqrt(wtr1(k,bi,bj))            write(weighttype(1:80),'(a)') "wvwind"
304  #else            call ctrl_set_pack_xy(
305                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)       &         cunit, ivartype, fname_vwind(ictrlgrad), "maskCtrlC",
306  #endif       &         weighttype, lxxadxx, mythid)
307                      endif  #endif
308                   enddo  
309                  enddo  #ifdef ALLOW_OBCSN_CONTROL
310                 enddo            ivartype = 11
311                enddo            write(weighttype(1:80),'(80a)') ' '
312               enddo            write(weighttype(1:80),'(a)') "wobcsn"
313              enddo            call ctrl_set_pack_xz(
314  c     --> check cbuffindex.       &         cunit, ivartype, fname_obcsn(ictrlgrad), "maskobcsn",
315              if ( cbuffindex .gt. 0) then       &         weighttype, wobcsn, lxxadxx, mythid)
316                 write(cunit) cbuffindex  #endif
317                 write(cunit) k  
318                 write(cunit) (cbuff(ii), ii=1,cbuffindex)  #ifdef ALLOW_OBCSS_CONTROL
319              endif            ivartype = 12
320           enddo            write(weighttype(1:80),'(80a)') ' '
321              write(weighttype(1:80),'(a)') "wobcss"
322  #endif            call ctrl_set_pack_xz(
323         &         cunit, ivartype, fname_obcss(ictrlgrad), "maskobcss",
324  #ifdef ALLOW_HFLUX0_CONTROL       &         weighttype, wobcss, lxxadxx, mythid)
325    #endif
326            il=ilnblnk( xx_hflux_file)  
327            write(fname(1:80),'(80a)') ' '  #ifdef ALLOW_OBCSW_CONTROL
328            write(fname(1:80),'(3a,i10.10)')            ivartype = 13
329       &         yadmark,xx_hflux_file(1:il),'.',optimcycle            write(weighttype(1:80),'(80a)') ' '
330  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO            write(weighttype(1:80),'(a)') "wobcsw"
331            call MDSREADFIELD_2D_GL( "whflux",            call ctrl_set_pack_yz(
332       &                          prec, 'RL', 1,       &         cunit, ivartype, fname_obcsw(ictrlgrad), "maskobcsw",
333       &                          globfld2d,       &         weighttype, wobcsw, lxxadxx, mythid)
334       &                          1,  mythid)  #endif
335  #endif  
336            call MDSREADFIELD_2D_GL( fname,  #ifdef ALLOW_OBCSE_CONTROL
337       &                          prec, 'RL', 1,            ivartype = 14
338       &                          globfld3d(1,1,1,1,1,1,1),            write(weighttype(1:80),'(80a)') ' '
339       &                          1,  mythid)            write(weighttype(1:80),'(a)') "wobcse"
340              call ctrl_set_pack_yz(
341            write(cunit) ncvarindex(3)       &         cunit, ivartype, fname_obcse(ictrlgrad), "maskobcse",
342            write(cunit) 1       &         weighttype, wobcse, lxxadxx, mythid)
           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),'(3a,i10.10)')  
      &         yadmark,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),'(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  
   
 #endif  
   
 #ifdef ALLOW_SST0_CONTROL  
   
           il=ilnblnk( xx_sst_file)  
           write(fname(1:80),'(80a)') ' '  
           write(fname(1:80),'(3a,i10.10)')  
      &         yadmark,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)  
 #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_SSS0_CONTROL  
   
           il=ilnblnk( xx_sss_file)  
           write(fname(1:80),'(80a)') ' '  
           write(fname(1:80),'(3a,i10.10)')  
      &         yadmark,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)  
 #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  
   
343  #endif  #endif
344    
345  #ifdef ALLOW_DIFFKR_CONTROL  #ifdef ALLOW_DIFFKR_CONTROL
346              ivartype = 15
347            il=ilnblnk( xx_diffkr_file)            write(weighttype(1:80),'(80a)') ' '
348            write(fname(1:80),'(80a)') ' '            write(weighttype(1:80),'(a)') "wdiffkr"
349            write(fname(1:80),'(3a,i10.10)')            call ctrl_set_pack_xyz(
350       &         yadmark,xx_diffkr_file(1:il),'.',optimcycle       &         cunit, ivartype, fname_diffkr(ictrlgrad), "maskCtrlC",
351         &         weighttype, wdiffkr, lxxadxx, mythid)
           call MDSREADFIELD_3D_GL( fname,  
      &                          prec, 'RL', Nr,  
      &                          globfld3d,  
      &                          1,  mythid)  
             
           write(cunit) ncvarindex(9)  
           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)  
 cph     &                      * sqrt(wdiffkr(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  
   
352  #endif  #endif
353    
354  #ifdef ALLOW_KAPGM_CONTROL  #ifdef ALLOW_KAPGM_CONTROL
355              ivartype = 16
356            il=ilnblnk( xx_kapgm_file)            write(weighttype(1:80),'(80a)') ' '
357            write(fname(1:80),'(80a)') ' '            write(weighttype(1:80),'(a)') "wkapgm"
358            write(fname(1:80),'(3a,i10.10)')            call ctrl_set_pack_xyz(
359       &         yadmark,xx_kapgm_file(1:il),'.',optimcycle       &         cunit, ivartype, fname_kapgm(ictrlgrad), "maskCtrlC",
360         &         weighttype, wkapgm, lxxadxx, mythid)
           call MDSREADFIELD_3D_GL( fname,  
      &                          prec, 'RL', Nr,  
      &                          globfld3d,  
      &                          1,  mythid)  
             
           write(cunit) ncvarindex(9)  
           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)  
 cph     &                      * sqrt(wkapgm(k,bi,bj))  
 #else  
                        cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  
361  #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  
          enddo  
362    
363    #ifdef ALLOW_TR10_CONTROL
364              ivartype = 17
365              write(weighttype(1:80),'(80a)') ' '
366              write(weighttype(1:80),'(a)') "wtr1"
367              call ctrl_set_pack_xyz(
368         &         cunit, ivartype, fname_tr1(ictrlgrad), "maskCtrlC",
369         &         weighttype, wunit, lxxadxx, mythid)
370    #endif
371    
372    #if (defined (ALLOW_SST_CONTROL) || defined (ALLOW_SST0_CONTROL))
373              ivartype = 18
374              write(weighttype(1:80),'(80a)') ' '
375              write(weighttype(1:80),'(a)') "wsst"
376              call ctrl_set_pack_xy(
377         &         cunit, ivartype, fname_sst(ictrlgrad), "maskCtrlC",
378         &         weighttype, lxxadxx, mythid)
379    #endif
380    
381    #if (defined (ALLOW_SSS_CONTROL) || defined (ALLOW_SSS0_CONTROL))
382              ivartype = 19
383              write(weighttype(1:80),'(80a)') ' '
384              write(weighttype(1:80),'(a)') "wsss"
385              call ctrl_set_pack_xy(
386         &         cunit, ivartype, fname_sss(ictrlgrad),
387         &         "maskCtrlC", weighttype, lxxadxx, mythid)
388    #endif
389    
390    #ifdef ALLOW_DEPTH_CONTROL
391              ivartype = 20
392              write(weighttype(1:80),'(80a)') ' '
393              write(weighttype(1:80),'(a)') "wdepth"
394              call ctrl_set_pack_xy(
395         &         cunit, ivartype, fname_depth(ictrlgrad),
396         &         "maskCtrlC", weighttype, lxxadxx, mythid)
397    #endif /* ALLOW_DEPTH_CONTROL */
398    
399    #ifdef ALLOW_EFLUXY0_CONTROL
400              ivartype = 21
401              write(weighttype(1:80),'(80a)') ' '
402              write(weighttype(1:80),'(a)') "wefluxy0"
403              call ctrl_set_pack_xyz(
404         &         cunit, ivartype, fname_efluxy(ictrlgrad), "maskCtrlS",
405         &         weighttype, wunit, lxxadxx, mythid)
406    #endif
407    
408    #ifdef ALLOW_EFLUXP0_CONTROL
409              ivartype = 22
410              write(weighttype(1:80),'(80a)') ' '
411              write(weighttype(1:80),'(a)') "wefluxp0"
412              call ctrl_set_pack_xyz(
413         &         cunit, ivartype, fname_efluxp(ictrlgrad), "maskhFacV",
414         &         weighttype, wunit, lxxadxx, mythid)
415    #endif
416    
417    #ifdef ALLOW_BOTTOMDRAG_CONTROL
418              ivartype = 23
419              write(weighttype(1:80),'(80a)') ' '
420              write(weighttype(1:80),'(a)') "wbottomdrag"
421              call ctrl_set_pack_xy(
422         &      cunit, ivartype, fname_bottomdrag(ictrlgrad), "maskCtrlC",
423         &      weighttype, lxxadxx, mythid)
424    #endif
425    
426    #ifdef ALLOW_EDTAUX_CONTROL
427              ivartype = 25
428              write(weighttype(1:80),'(80a)') ' '
429              write(weighttype(1:80),'(a)') "wedtaux"
430              call ctrl_set_pack_xyz(
431         &         cunit, ivartype, fname_edtaux(ictrlgrad), "maskCtrlW",
432         &         weighttype, wedtaux, lxxadxx, mythid)
433    #endif
434    
435    #ifdef ALLOW_EDTAUY_CONTROL
436              ivartype = 26
437              write(weighttype(1:80),'(80a)') ' '
438              write(weighttype(1:80),'(a)') "wedtauy"
439              call ctrl_set_pack_xyz(
440         &         cunit, ivartype, fname_edtauy(ictrlgrad), "maskCtrlS",
441         &         weighttype, wedtauy, lxxadxx, mythid)
442    #endif
443    
444    #ifdef ALLOW_UVEL0_CONTROL
445              ivartype = 27
446              write(weighttype(1:80),'(80a)') ' '
447              write(weighttype(1:80),'(a)') "wuvel"
448              call ctrl_set_pack_xyz(
449         &         cunit, ivartype, fname_uvel(ictrlgrad), "maskCtrlW",
450         &         weighttype, wunit, lxxadxx, mythid)
451    #endif
452    
453    #ifdef ALLOW_VVEL0_CONTROL
454              ivartype = 28
455              write(weighttype(1:80),'(80a)') ' '
456              write(weighttype(1:80),'(a)') "wvvel"
457              call ctrl_set_pack_xyz(
458         &         cunit, ivartype, fname_vvel(ictrlgrad), "maskCtrlS",
459         &         weighttype, wunit, lxxadxx, mythid)
460    #endif
461    
462    #ifdef ALLOW_ETAN0_CONTROL
463              ivartype = 29
464              write(weighttype(1:80),'(80a)') ' '
465              write(weighttype(1:80),'(a)') "wetan"
466              call ctrl_set_pack_xy(
467         &         cunit, ivartype, fname_etan(ictrlgrad),
468         &         "maskCtrlC", weighttype, lxxadxx, mythid)
469    #endif
470    
471    #ifdef ALLOW_RELAXSST_CONTROL
472              ivartype = 30
473              write(weighttype(1:80),'(80a)') ' '
474              write(weighttype(1:80),'(a)') "wrelaxsst"
475              call ctrl_set_pack_xy(
476         &         cunit, ivartype, fname_relaxsst(ictrlgrad),
477         &         "maskCtrlC", weighttype, lxxadxx, mythid)
478    #endif
479    
480    #ifdef ALLOW_RELAXSSS_CONTROL
481              ivartype = 31
482              write(weighttype(1:80),'(80a)') ' '
483              write(weighttype(1:80),'(a)') "wrelaxsss"
484              call ctrl_set_pack_xy(
485         &         cunit, ivartype, fname_relaxsss(ictrlgrad),
486         &         "maskCtrlC", weighttype, lxxadxx, mythid)
487    #endif
488    
489    #ifdef ALLOW_PRECIP_CONTROL
490              ivartype = 32
491              write(weighttype(1:80),'(80a)') ' '
492              write(weighttype(1:80),'(a)') "wprecip"
493              call ctrl_set_pack_xy(
494         &         cunit, ivartype, fname_precip(ictrlgrad),
495         &         "maskCtrlC", weighttype, lxxadxx, mythid)
496    #endif
497    
498    #ifdef ALLOW_SWFLUX_CONTROL
499              ivartype = 33
500              write(weighttype(1:80),'(80a)') ' '
501              write(weighttype(1:80),'(a)') "wswflux"
502              call ctrl_set_pack_xy(
503         &         cunit, ivartype, fname_swflux(ictrlgrad),
504         &         "maskCtrlC", weighttype, lxxadxx, mythid)
505    #endif
506    
507    #ifdef ALLOW_SWDOWN_CONTROL
508              ivartype = 34
509              write(weighttype(1:80),'(80a)') ' '
510              write(weighttype(1:80),'(a)') "wswdown"
511              call ctrl_set_pack_xy(
512         &         cunit, ivartype, fname_swdown(ictrlgrad),
513         &         "maskCtrlC", weighttype, lxxadxx, mythid)
514    #endif
515    
516    #ifdef ALLOW_LWFLUX_CONTROL
517              ivartype = 35
518              write(weighttype(1:80),'(80a)') ' '
519              write(weighttype(1:80),'(a)') "wlwflux"
520              call ctrl_set_pack_xy(
521         &         cunit, ivartype, fname_lwflux(ictrlgrad),
522         &         "maskCtrlC", weighttype, lxxadxx, mythid)
523    #endif
524    
525    #ifdef ALLOW_LWDOWN_CONTROL
526              ivartype = 36
527              write(weighttype(1:80),'(80a)') ' '
528              write(weighttype(1:80),'(a)') "wlwdown"
529              call ctrl_set_pack_xy(
530         &         cunit, ivartype, fname_lwdown(ictrlgrad),
531         &         "maskCtrlC", weighttype, lxxadxx, mythid)
532    #endif
533    
534    #ifdef ALLOW_EVAP_CONTROL
535              ivartype = 37
536              write(weighttype(1:80),'(80a)') ' '
537              write(weighttype(1:80),'(a)') "wevap"
538              call ctrl_set_pack_xy(
539         &         cunit, ivartype, fname_evap(ictrlgrad),
540         &         "maskCtrlC", weighttype, lxxadxx, mythid)
541    #endif
542    
543    #ifdef ALLOW_SNOWPRECIP_CONTROL
544              ivartype = 38
545              write(weighttype(1:80),'(80a)') ' '
546              write(weighttype(1:80),'(a)') "wsnowprecip"
547              call ctrl_set_pack_xy(
548         &         cunit, ivartype, fname_snowprecip(ictrlgrad),
549         &         "maskCtrlC", weighttype, lxxadxx, mythid)
550    #endif
551    
552    #ifdef ALLOW_APRESSURE_CONTROL
553              ivartype = 39
554              write(weighttype(1:80),'(80a)') ' '
555              write(weighttype(1:80),'(a)') "wapressure"
556              call ctrl_set_pack_xy(
557         &         cunit, ivartype, fname_apressure(ictrlgrad),
558         &         "maskCtrlC", weighttype, lxxadxx, mythid)
559    #endif
560    
561    #ifdef ALLOW_RUNOFF_CONTROL
562              ivartype = 40
563              write(weighttype(1:80),'(80a)') ' '
564              write(weighttype(1:80),'(a)') "wrunoff"
565              call ctrl_set_pack_xy(
566         &         cunit, ivartype, fname_runoff(ictrlgrad),
567         &         "maskCtrlC", weighttype, lxxadxx, mythid)
568    #endif
569    
570    #ifdef ALLOW_SIAREA_CONTROL
571              ivartype = 41
572              write(weighttype(1:80),'(80a)') ' '
573              write(weighttype(1:80),'(a)') "wunit"
574              call ctrl_set_pack_xy(
575         &         cunit, ivartype, fname_siarea(ictrlgrad),
576         &         "maskCtrlC", weighttype, lxxadxx, mythid)
577    #endif
578    
579    #ifdef ALLOW_SIHEFF_CONTROL
580              ivartype = 42
581              write(weighttype(1:80),'(80a)') ' '
582              write(weighttype(1:80),'(a)') "wunit"
583              call ctrl_set_pack_xy(
584         &         cunit, ivartype, fname_siheff(ictrlgrad),
585         &         "maskCtrlC", weighttype, lxxadxx, mythid)
586    #endif
587    
588    #ifdef ALLOW_SIHSNOW_CONTROL
589              ivartype = 43
590              write(weighttype(1:80),'(80a)') ' '
591              write(weighttype(1:80),'(a)') "wunit"
592              call ctrl_set_pack_xy(
593         &         cunit, ivartype, fname_sihsnow(ictrlgrad),
594         &         "maskCtrlC", weighttype, lxxadxx, mythid)
595  #endif  #endif
596    
   
597            close ( cunit )            close ( cunit )
598    
599            _END_MASTER( mythid )
600    
601    #endif /* EXCLUDE_CTRL_PACK */
602    
603        return        return
604        end        end
605    
Legend:
Removed from v.1.4  
changed lines
  Added in v.1.30
  ViewVC Help
Powered by ViewVC 1.1.22