/[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.4.6.7 by heimbach, Thu Jul 24 21:57:48 2003 UTC
# Line 1  Line 1 
 C $Header$  
1    
2  #include "CTRL_CPPOPTIONS.h"  #include "CTRL_CPPOPTIONS.h"
3    
 CBOP  
 C     !ROUTINE: ctrl_pack  
 C     !INTERFACE:  
       subroutine ctrl_pack( myiter, mytime, mythid )  
   
 C     !DESCRIPTION: \bv  
 c     *=================================================================  
 c     | SUBROUTINE ctrl_pack  
 c     | Pack the control vector  
 c     | * All control variable and adjoint variable fields are  
 c     |   read from disk.  
 c     | * Wet points are extracted, and elements are  
 c     |   normalized (optional)  
 c     | * A single control vector containing only (normalized  
 c     |   wet points is written to file.  
 c     *=================================================================  
 C     \ev  
4    
5  C     !USES:        subroutine ctrl_pack(
6         I                      myiter,
7         I                      mytime,
8         I                      mythid
9         &                    )
10    
11    c     ==================================================================
12    c     SUBROUTINE ctrl_pack
13    c     ==================================================================
14    c
15    c     o Compress the control vector such that only ocean points are
16    c       written to file.
17    c
18    c     started: Christian Eckert eckert@mit.edu  10-Mar=2000
19    c
20    c     changed: Patrick Heimbach heimbach@mit.edu 06-Jun-2000
21    c              - Transferred some filename declarations
22    c                from here to namelist in ctrl_init
23    c  
24    c              Patrick Heimbach heimbach@mit.edu 16-Jun-2000
25    c              - single file name convention with or without
26    c                ALLOW_ECCO_OPTIMIZATION
27    c
28    c              G. Gebbie, added open boundary control packing,
29    c                  gebbie@mit.edu  18 -Mar- 2003
30    c
31    c     ==================================================================
32    c     SUBROUTINE ctrl_pack
33    c     ==================================================================
34    
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 "ecco.h"
45  #include "ctrl.h"  #include "ctrl.h"
46  #include "cost.h"  #include "cost.h"
47    
48    #ifdef ALLOW_ECCO_OPTIMIZATION
49  #include "optim.h"  #include "optim.h"
50    #endif
51    
 C     !INPUT/OUTPUT PARAMETERS:  
52  c     == routine arguments ==  c     == routine arguments ==
53    
54        integer myiter        integer myiter
55        _RL     mytime        _RL     mytime
56        integer mythid        integer mythid
57    
 C     !LOCAL VARIABLES:  
58  c     == local variables ==  c     == local variables ==
59    
60        integer bi,bj  #ifndef ALLOW_ECCO_OPTIMIZATION
61        integer ip,jp        integer optimcycle
62        integer i,j,k  #endif
63    
64          integer i, j, k
65        integer ii        integer ii
66        integer il        integer il
67        integer irec        integer irec
68        integer itlo,ithi        integer ig,jg
69        integer jtlo,jthi        integer ivartype
70        integer jmin,jmax        integer iobcs
       integer imin,imax  
       integer cbuffindex  
       integer cunit  
       integer prec  
71    
72        logical doglobalread        logical doglobalread
73        logical ladinit        logical ladinit
74          integer cbuffindex
75    
76        _RL     cbuff( snx*nsx*npx*sny*nsy*npy )        integer cunit
       _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 )  
77        _RL     tmpvar        _RL     tmpvar
78    
79        character*(128) cfile        character*(128) cfile
80        character*( 80) fname        character*( 80) weighttype
81    
82          character*( 80) fname_theta
83          character*( 80) fname_salt
84          character*( 80) fname_hflux
85          character*( 80) fname_sflux
86          character*( 80) fname_tauu
87          character*( 80) fname_tauv
88          character*( 80) adfname_theta
89          character*( 80) adfname_salt
90          character*( 80) adfname_hflux
91          character*( 80) adfname_sflux
92          character*( 80) adfname_tauu
93          character*( 80) adfname_tauv
94          character*( 80)   fname_atemp
95          character*( 80) adfname_atemp
96          character*( 80)   fname_aqh
97          character*( 80) adfname_aqh
98          character*( 80)   fname_uwind
99          character*( 80) adfname_uwind
100          character*( 80)   fname_vwind
101          character*( 80) adfname_vwind
102          character*( 80)   fname_obcsn
103          character*( 80) adfname_obcsn
104          character*( 80)   fname_obcss
105          character*( 80) adfname_obcss
106          character*( 80)   fname_obcsw
107          character*( 80) adfname_obcsw
108          character*( 80)   fname_obcse
109          character*( 80) adfname_obcse
110          character*( 80)   fname_diffkr
111          character*( 80) adfname_diffkr
112          character*( 80)   fname_kapgm
113          character*( 80) adfname_kapgm
114          character*( 80)   fname_tr1
115          character*( 80) adfname_tr1
116          character*( 80)   fname_sst
117          character*( 80) adfname_sst
118          character*( 80)   fname_sss
119          character*( 80) adfname_sss
120          character*( 80)   fname_hfacc
121          character*( 80) adfname_hfacc
122          character*( 80)   fname_efluxy
123          character*( 80) adfname_efluxy
124          character*( 80)   fname_efluxp
125          character*( 80) adfname_efluxp
126          character*( 80)   fname_bottomdrag
127          character*( 80) adfname_bottomdrag
128    
129          logical lxxadxx
130    
131  c     == external ==  c     == external ==
132    
133        integer  ilnblnk        integer  ilnblnk
134        external ilnblnk        external ilnblnk
135    
136  c     == end of interface ==  c     == end of interface ==
 CEOP  
137    
138        prec           = precFloat64  #ifndef ALLOW_ECCO_OPTIMIZATION
139        tmpvar         = -9999. _d 0        optimcycle = 0
140    #endif
141    
142        jtlo = 1        tmpvar = -9999. _d 0
       jthi = nsy  
       itlo = 1  
       ithi = nsx  
       jmin = 1  
       jmax = sny  
       imin = 1  
       imax = snx  
143    
144  c--   Tiled files are used.  c--   Tiled files are used.
145        doglobalread = .false.        doglobalread = .false.
# Line 92  c--   Tiled files are used. Line 147  c--   Tiled files are used.
147  c--   Initialise adjoint variables on active files.  c--   Initialise adjoint variables on active files.
148        ladinit = .false.        ladinit = .false.
149    
150  c  c--   Assign file names.
 c--   Only the master thread will do I/O.  
       _BEGIN_MASTER( mythid )  
151    
152  c--   read global mask file        call ctrl_set_fname(
153            call MDSREADFIELD_3D_GL( "hFacC",       I     xx_theta_file, fname_theta, adfname_theta, mythid )
154       &                           prec, 'RL', Nr, globmsk,        call ctrl_set_fname(
155       &                           1,  mythid)       I     xx_salt_file, fname_salt, adfname_salt, mythid )
156          call ctrl_set_fname(
157         I     xx_hflux_file, fname_hflux, adfname_hflux, mythid )
158          call ctrl_set_fname(
159         I     xx_sflux_file, fname_sflux, adfname_sflux, mythid )
160          call ctrl_set_fname(
161         I     xx_tauu_file, fname_tauu, adfname_tauu, mythid )
162          call ctrl_set_fname(
163         I     xx_tauv_file, fname_tauv, adfname_tauv, mythid )
164          call ctrl_set_fname(
165         I     xx_atemp_file, fname_atemp, adfname_atemp, mythid )
166          call ctrl_set_fname(
167         I     xx_aqh_file, fname_aqh, adfname_aqh, mythid )
168          call ctrl_set_fname(
169         I     xx_uwind_file, fname_uwind, adfname_uwind, mythid )
170          call ctrl_set_fname(
171         I     xx_vwind_file, fname_vwind, adfname_vwind, mythid )
172          call ctrl_set_fname(
173         I     xx_obcsn_file, fname_obcsn, adfname_obcsn, mythid )
174          call ctrl_set_fname(
175         I     xx_obcss_file, fname_obcss, adfname_obcss, mythid )
176          call ctrl_set_fname(
177         I     xx_obcsw_file, fname_obcsw, adfname_obcsw, mythid )
178          call ctrl_set_fname(
179         I     xx_obcse_file, fname_obcse, adfname_obcse, mythid )
180          call ctrl_set_fname(
181         I     xx_diffkr_file, fname_diffkr, adfname_diffkr, mythid )
182          call ctrl_set_fname(
183         I     xx_kapgm_file, fname_kapgm, adfname_kapgm, mythid )
184          call ctrl_set_fname(
185         I     xx_tr1_file, fname_tr1, adfname_tr1, mythid )
186          call ctrl_set_fname(
187         I     xx_sst_file, fname_sst, adfname_sst, mythid )
188          call ctrl_set_fname(
189         I     xx_sss_file, fname_sss, adfname_sss, mythid )
190          call ctrl_set_fname(
191         I     xx_hfacc_file, fname_hfacc, adfname_hfacc, mythid )
192          call ctrl_set_fname(
193         I     xx_efluxy_file, fname_efluxy, adfname_efluxy, mythid )
194          call ctrl_set_fname(
195         I     xx_efluxp_file, fname_efluxp, adfname_efluxp, mythid )
196          call ctrl_set_fname(
197         I     xx_bottomdrag_file, fname_bottomdrag, adfname_bottomdrag
198         I   , mythid )
199    
200    c
201    c--     Only the master thread will do I/O.
202          _BEGIN_MASTER( mythid )
203    
204  c     >>> Write control vector <<<  c     >>> Write control vector <<<
205    
206            call mdsfindunit( cunit, mythid )  cph   this part was removed since it's not necessary
207            write(cfile(1:128),'(2a,i4.4)')  cph   and causes huge amounts of wall clock time on parallel machines
      &      ctrlname(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) tmpvar  
           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)  
           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  
208    
           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)  
209    
           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)  
           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),'(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  
   
 #endif  
   
 #ifdef ALLOW_DIFFKR_CONTROL  
   
           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)  
 #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_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)  
210    
211  c     >>> Write gradient vector <<<  c     >>> Write gradient vector <<<
212          lxxadxx = .FALSE.
213    
214            call mdsfindunit( cunit, mythid )            call mdsfindunit( cunit, mythid )
215            write(cfile(1:128),'(2a,i4.4)')            write(cfile(1:128),'(4a,i4.4)')
216       &    costname(1:9),'.opt',       &    costname(1:9),'_',yctrlid(1:10),'.opt',
217       &    optimcycle       &    optimcycle
218    
219            open( cunit, file   = cfile,            open( cunit, file   = cfile,
# Line 704  c     >>> Write gradient vector <<< Line 224  c     >>> Write gradient vector <<<
224  c--       Header information.  c--       Header information.
225            write(cunit) nvartype            write(cunit) nvartype
226            write(cunit) nvarlength            write(cunit) nvarlength
227            write(cunit) expId            write(cunit) yctrlid
228            write(cunit) optimCycle            write(cunit) optimCycle
229            write(cunit) fc            write(cunit) fc
230            write(cunit) 1            write(cunit) 1
231            write(cunit) 1            write(cunit) 1
232            write(cunit) 1            write(cunit) 1
233            write(cunit) 1            write(cunit) 1
234            write(cunit) (nWetcTile(1,1,k), k=1,nr)            write(cunit) (nWetcGlobal(k), k=1,nr)
235            write(cunit) (nWetsTile(1,1,k), k=1,nr)            write(cunit) (nWetsGlobal(k), k=1,nr)
236            write(cunit) (nWetwTile(1,1,k), k=1,nr)            write(cunit) (nWetwGlobal(k), k=1,nr)
237    #ifdef ALLOW_CTRL_WETV
238              write(cunit) (nWetvGlobal(k), k=1,nr)
239    #endif
240    #ifdef ALLOW_OBCSN_CONTROL
241              write(cunit) ((nWetobcsnGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
242    #endif
243    #ifdef ALLOW_OBCSS_CONTROL
244              write(cunit) ((nWetobcssGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
245    #endif
246    #ifdef ALLOW_OBCSW_CONTROL
247              write(cunit) ((nWetobcswGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
248    #endif
249    #ifdef ALLOW_OBCSE_CONTROL
250              write(cunit) ((nWetobcseGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
251    #endif
252            write(cunit) (ncvarindex(i), i=1,maxcvars)            write(cunit) (ncvarindex(i), i=1,maxcvars)
253            write(cunit) (ncvarrecs(i),  i=1,maxcvars)            write(cunit) (ncvarrecs(i),  i=1,maxcvars)
254            write(cunit) (nx,  i=1,maxcvars)            write(cunit) (nx,  i=1,maxcvars)
# Line 723  c--       Header information. Line 258  c--       Header information.
258            write(cunit)            write(cunit)
259    
260  #ifdef ALLOW_THETA0_CONTROL  #ifdef ALLOW_THETA0_CONTROL
261              ivartype = 1
262            il=ilnblnk( xx_theta_file)            write(weighttype(1:80),'(80a)') ' '
263            write(fname(1:80),'(80a)') ' '            write(weighttype(1:80),'(a)') "wtheta"
264            write(fname(1:80),'(3a,i10.10)')            call ctrl_set_pack_xyz(
265       &         yadmark,xx_theta_file(1:il),'.',optimcycle       &         cunit, ivartype, adfname_theta, "hFacC",
266         &         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  
   
267  #endif  #endif
268    
269  #ifdef ALLOW_SALT0_CONTROL  #ifdef ALLOW_SALT0_CONTROL
270              ivartype = 2
271            il=ilnblnk( xx_salt_file)            write(weighttype(1:80),'(80a)') ' '
272            write(fname(1:80),'(80a)') ' '            write(weighttype(1:80),'(a)') "wsalt"
273            write(fname(1:80),'(3a,i10.10)')            call ctrl_set_pack_xyz(
274       &         yadmark,xx_salt_file(1:il),'.',optimcycle       &         cunit, ivartype, adfname_salt, "hFacC",
275         &         weighttype, wsalt, lxxadxx, mythid)
276            call MDSREADFIELD_3D_GL( fname,  #endif
277       &                          prec, 'RL', Nr,  
278       &                          globfld3d,  #if (defined (ALLOW_HFLUX_CONTROL) || \
279       &                          1,  mythid)       defined (ALLOW_HFLUX0_CONTROL))
280                        ivartype = 3
281            write(cunit) ncvarindex(2)            write(weighttype(1:80),'(80a)') ' '
282            write(cunit) 1            write(weighttype(1:80),'(a)') "whflux"
283            write(cunit) 1            call ctrl_set_pack_xy(
284            do k = 1,nr       &         cunit, ivartype, adfname_hflux, "hFacC", weighttype,
285             cbuffindex = 0       &         lxxadxx, mythid)
286              do jp = 1,nPy  #endif
287               do bj = jtlo,jthi  
288                do j = jmin,jmax  #if (defined (ALLOW_SFLUX_CONTROL) || \
289                 do ip = 1,nPx       defined (ALLOW_SFLUX0_CONTROL))
290                  do bi = itlo,ithi            ivartype = 4
291                   do i = imin,imax            write(weighttype(1:80),'(80a)') ' '
292                      if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then            write(weighttype(1:80),'(a)') "wsflux"
293                         cbuffindex = cbuffindex + 1            call ctrl_set_pack_xy(
294  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO       &         cunit, ivartype, adfname_sflux, "hFacC", weighttype,
295                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)       &         lxxadxx, mythid)
296       &                      * sqrt(wsalt(k,bi,bj))  #endif
297  #else  
298                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  #if (defined (ALLOW_USTRESS_CONTROL) || \
299  #endif       defined (ALLOW_TAUU0_CONTROL))
300                      endif            ivartype = 5
301                   enddo            write(weighttype(1:80),'(80a)') ' '
302                  enddo            write(weighttype(1:80),'(a)') "wtauu"
303                 enddo            call ctrl_set_pack_xy(
304                enddo       &         cunit, ivartype, adfname_tauu, "maskW", weighttype,
305               enddo       &         lxxadxx, mythid)
306              enddo  #endif
307  c     --> check cbuffindex.  
308              if ( cbuffindex .gt. 0) then  #if (defined (ALLOW_VSTRESS_CONTROL) || \
309                 write(cunit) cbuffindex       defined (ALLOW_TAUV0_CONTROL))
310                 write(cunit) k            ivartype = 6
311                 write(cunit) (cbuff(ii), ii=1,cbuffindex)            write(weighttype(1:80),'(80a)') ' '
312              endif            write(weighttype(1:80),'(a)') "wtauv"
313           enddo            call ctrl_set_pack_xy(
314         &         cunit, ivartype, adfname_tauv, "maskS", weighttype,
315  #endif       &         lxxadxx, mythid)
316    #endif
317  #ifdef ALLOW_TR10_CONTROL  
318    #ifdef ALLOW_ATEMP_CONTROL
319            il=ilnblnk( xx_tr1_file)            ivartype = 7
320            write(fname(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
321            write(fname(1:80),'(3a,i10.10)')            write(weighttype(1:80),'(a)') "watemp"
322       &         yadmark,xx_tr1_file(1:il),'.',optimcycle            call ctrl_set_pack_xy(
323         &         cunit, ivartype, adfname_atemp, "hFacC", weighttype,
324            call MDSREADFIELD_3D_GL( fname,       &         lxxadxx, mythid)
325       &                          prec, 'RL', Nr,  #endif
326       &                          globfld3d,  
327       &                          1,  mythid)  #ifdef ALLOW_AQH_CONTROL
328                        ivartype = 8
329            write(cunit) ncvarindex(9)            write(weighttype(1:80),'(80a)') ' '
330            write(cunit) 1            write(weighttype(1:80),'(a)') "waqh"
331            write(cunit) 1            call ctrl_set_pack_xy(
332            do k = 1,nr       &         cunit, ivartype, adfname_aqh, "hFacC", weighttype,
333             cbuffindex = 0       &         lxxadxx, mythid)
334              do jp = 1,nPy  #endif
335               do bj = jtlo,jthi  
336                do j = jmin,jmax  #ifdef ALLOW_UWIND_CONTROL
337                 do ip = 1,nPx            ivartype = 9
338                  do bi = itlo,ithi            write(weighttype(1:80),'(80a)') ' '
339                   do i = imin,imax            write(weighttype(1:80),'(a)') "wuwind"
340                      if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then            call ctrl_set_pack_xy(
341                         cbuffindex = cbuffindex + 1       &         cunit, ivartype, adfname_uwind, "maskW", weighttype,
342  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO       &         lxxadxx, mythid)
343                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  #endif
344  cph     &                      * sqrt(wtr1(k,bi,bj))  
345  #else  #ifdef ALLOW_VWIND_CONTROL
346                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)            ivartype = 10
347  #endif            write(weighttype(1:80),'(80a)') ' '
348                      endif            write(weighttype(1:80),'(a)') "wvwind"
349                   enddo            call ctrl_set_pack_xy(
350                  enddo       &         cunit, ivartype, adfname_vwind, "maskS", weighttype,
351                 enddo       &         lxxadxx, mythid)
352                enddo  #endif
353               enddo  
354              enddo  #ifdef ALLOW_OBCSN_CONTROL
355  c     --> check cbuffindex.            ivartype = 11
356              if ( cbuffindex .gt. 0) then            write(weighttype(1:80),'(80a)') ' '
357                 write(cunit) cbuffindex            write(weighttype(1:80),'(a)') "wobcsn"
358                 write(cunit) k            call ctrl_set_pack_xz(
359                 write(cunit) (cbuff(ii), ii=1,cbuffindex)       &         cunit, ivartype, adfname_obcsn, "maskobcsn",
360              endif       &         weighttype, wobcsn, lxxadxx, mythid)
361           enddo  #endif
362    
363  #endif  #ifdef ALLOW_OBCSS_CONTROL
364              ivartype = 12
365  #ifdef ALLOW_HFLUX0_CONTROL            write(weighttype(1:80),'(80a)') ' '
366              write(weighttype(1:80),'(a)') "wobcss"
367            il=ilnblnk( xx_hflux_file)            call ctrl_set_pack_xz(
368            write(fname(1:80),'(80a)') ' '       &         cunit, ivartype, adfname_obcss, "maskobcss",
369            write(fname(1:80),'(3a,i10.10)')       &         weighttype, wobcss, lxxadxx, mythid)
370       &         yadmark,xx_hflux_file(1:il),'.',optimcycle  #endif
371  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  
372            call MDSREADFIELD_2D_GL( "whflux",  #ifdef ALLOW_OBCSW_CONTROL
373       &                          prec, 'RL', 1,            ivartype = 13
374       &                          globfld2d,            write(weighttype(1:80),'(80a)') ' '
375       &                          1,  mythid)            write(weighttype(1:80),'(a)') "wobcsw"
376  #endif            call ctrl_set_pack_yz(
377            call MDSREADFIELD_2D_GL( fname,       &         cunit, ivartype, adfname_obcsw, "maskobcsw",
378       &                          prec, 'RL', 1,       &         weighttype, wobcsw, lxxadxx, mythid)
379       &                          globfld3d(1,1,1,1,1,1,1),  #endif
380       &                          1,  mythid)  
381    #ifdef ALLOW_OBCSE_CONTROL
382            write(cunit) ncvarindex(3)            ivartype = 14
383            write(cunit) 1            write(weighttype(1:80),'(80a)') ' '
384            write(cunit) 1            write(weighttype(1:80),'(a)') "wobcse"
385            k = 1            call ctrl_set_pack_yz(
386             cbuffindex = 0       &         cunit, ivartype, adfname_obcse, "maskobcse",
387              do jp = 1,nPy       &         weighttype, wobcse, lxxadxx, mythid)
              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  
   
388  #endif  #endif
389    
390  #ifdef ALLOW_SFLUX0_CONTROL  #ifdef ALLOW_DIFFKR_CONTROL
391              ivartype = 15
392            il=ilnblnk( xx_sflux_file)            write(weighttype(1:80),'(80a)') ' '
393            write(fname(1:80),'(80a)') ' '            write(weighttype(1:80),'(a)') "wdiffkr"
394            write(fname(1:80),'(3a,i10.10)')            call ctrl_set_pack_xyz(
395       &         yadmark,xx_sflux_file(1:il),'.',optimcycle       &         cunit, ivartype, adfname_diffkr, "hFacC",
396  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO       &         weighttype, wunit, lxxadxx, mythid)
           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  
   
397  #endif  #endif
398    
399  #ifdef ALLOW_TAUU0_CONTROL  #ifdef ALLOW_KAPGM_CONTROL
400              ivartype = 16
401            il=ilnblnk( xx_tauu_file)            write(weighttype(1:80),'(80a)') ' '
402            write(fname(1:80),'(80a)') ' '            write(weighttype(1:80),'(a)') "wkapgm"
403            write(fname(1:80),'(3a,i10.10)')            call ctrl_set_pack_xyz(
404       &         yadmark,xx_tauu_file(1:il),'.',optimcycle       &         cunit, ivartype, adfname_kapgm, "hFacC",
405  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO       &         weighttype, wunit, lxxadxx, mythid)
           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  
   
406  #endif  #endif
407    
408  #ifdef ALLOW_TAUV0_CONTROL  #ifdef ALLOW_TR10_CONTROL
409              ivartype = 17
410            il=ilnblnk( xx_tauv_file)            write(weighttype(1:80),'(80a)') ' '
411            write(fname(1:80),'(80a)') ' '            write(weighttype(1:80),'(a)') "wtr1"
412            write(fname(1:80),'(3a,i10.10)')            call ctrl_set_pack_xyz(
413       &         yadmark,xx_tauv_file(1:il),'.',optimcycle       &         cunit, ivartype, adfname_tr1, "hFacC",
414  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO       &         weighttype, wunit, lxxadxx, mythid)
           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  
   
415  #endif  #endif
416    
417  #ifdef ALLOW_SST0_CONTROL  #ifdef ALLOW_SST0_CONTROL
418              ivartype = 18
419            il=ilnblnk( xx_sst_file)            write(weighttype(1:80),'(80a)') ' '
420            write(fname(1:80),'(80a)') ' '            write(weighttype(1:80),'(a)') "wsst0"
421            write(fname(1:80),'(3a,i10.10)')            call ctrl_set_pack_xy(
422       &         yadmark,xx_sst_file(1:il),'.',optimcycle       &         cunit, ivartype, adfname_sst, "hFacC", weighttype,
423  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO       &         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  
   
424  #endif  #endif
425    
426  #ifdef ALLOW_SSS0_CONTROL  #ifdef ALLOW_SSS0_CONTROL
427              ivartype = 19
428            il=ilnblnk( xx_sss_file)            write(weighttype(1:80),'(80a)') ' '
429            write(fname(1:80),'(80a)') ' '            write(weighttype(1:80),'(a)') "wsss0"
430            write(fname(1:80),'(3a,i10.10)')            call ctrl_set_pack_xy(
431       &         yadmark,xx_sss_file(1:il),'.',optimcycle       &         cunit, ivartype, adfname_sss, "hFacC", weighttype,
432  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO       &         lxxadxx, mythid)
433            call MDSREADFIELD_2D_GL( "wsss",  #endif
434       &                          prec, 'RL', 1,  
435       &                          globfld2d,  #ifdef ALLOW_HFACC_CONTROL
436       &                          1,  mythid)            ivartype = 20
437  #endif            write(weighttype(1:80),'(80a)') ' '
438            call MDSREADFIELD_2D_GL( fname,            write(weighttype(1:80),'(a)') "whfacc"
439       &                          prec, 'RL', 1,  # ifdef ALLOW_HFACC3D_CONTROL
440       &                          globfld3d(1,1,1,1,1,1,1),            call ctrl_set_pack_xyz(
441       &                          1,  mythid)       &         cunit, ivartype, adfname_hfacc, "hFacC",
442         &         weighttype, wunit, lxxadxx, mythid)
443            write(cunit) ncvarindex(8)  # else
444            write(cunit) 1            call ctrl_set_pack_xy(
445            write(cunit) 1       &         cunit, ivartype, adfname_hfacc, "hFacC", weighttype,
446            k = 1       &         lxxadxx, mythid)
447             cbuffindex = 0  # endif
448              do jp = 1,nPy  #endif
449               do bj = jtlo,jthi  
450                do j = jmin,jmax  #ifdef ALLOW_EFLUXY0_CONTROL
451                 do ip = 1,nPx            ivartype = 21
452                  do bi = itlo,ithi            write(weighttype(1:80),'(80a)') ' '
453                   do i = imin,imax            write(weighttype(1:80),'(a)') "wefluxy0"
454                      if (globmsk(i,bi,ip,j,bj,jp,k)  .ne. 0. ) then            call ctrl_set_pack_xyz(
455                         cbuffindex = cbuffindex + 1       &         cunit, ivartype, adfname_efluxy, "hFacS",
456  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO       &         weighttype, wunit, lxxadxx, mythid)
457                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)  #endif
458       &                      * sqrt(globfld2d(i,bi,ip,j,bj,jp))  
459  #else  #ifdef ALLOW_EFLUXP0_CONTROL
460                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)            ivartype = 22
461  #endif            write(weighttype(1:80),'(80a)') ' '
462                      endif            write(weighttype(1:80),'(a)') "wefluxp0"
463                   enddo            call ctrl_set_pack_xyz(
464                  enddo       &         cunit, ivartype, adfname_efluxp, "hFacV",
465                 enddo       &         weighttype, wunit, lxxadxx, mythid)
466                enddo  #endif
467               enddo  
468              enddo  #ifdef ALLOW_BOTTOMDRAG_CONTROL
469  c     --> check cbuffindex.            ivartype = 23
470              if ( cbuffindex .gt. 0) then            write(weighttype(1:80),'(80a)') ' '
471                 write(cunit) cbuffindex            write(weighttype(1:80),'(a)') "wbottomdrag"
472                 write(cunit) k            call ctrl_set_pack_xy(
473                 write(cunit) (cbuff(ii), ii=1,cbuffindex)       &         cunit, ivartype, adfname_bottomdrag, "hFacC", weighttype,
474              endif       &         lxxadxx, mythid)
   
475  #endif  #endif
476    
 #ifdef ALLOW_DIFFKR_CONTROL  
   
           il=ilnblnk( xx_diffkr_file)  
           write(fname(1:80),'(80a)') ' '  
           write(fname(1:80),'(3a,i10.10)')  
      &         yadmark,xx_diffkr_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(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  
   
 #endif  
   
 #ifdef ALLOW_KAPGM_CONTROL  
   
           il=ilnblnk( xx_kapgm_file)  
           write(fname(1:80),'(80a)') ' '  
           write(fname(1:80),'(3a,i10.10)')  
      &         yadmark,xx_kapgm_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(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  
   
   
477            close ( cunit )            close ( cunit )
478    
479            _END_MASTER( mythid )
480    
481        return        return
482        end        end
483    
Legend:
Removed from v.1.4  
changed lines
  Added in v.1.4.6.7
  ViewVC Help
Powered by ViewVC 1.1.22