pkg/ctrl/ctrl_set_pack_xyz.F

C
C $Header: /u/gcmpack/MITgcm/pkg/ctrl/ctrl_set_pack_xyz.F,v 1.5 2003/10/23 04:41:40 edhill Exp $
C $Name:  $

#include "CTRL_CPPOPTIONS.h"


      subroutine ctrl_set_pack_xyz(
     &     cunit, ivartype, fname, masktype, weighttype,
     &     weightfld, lxxadxx, mythid)

c     ==================================================================
c     SUBROUTINE ctrl_set_pack_xyz
c     ==================================================================
c
c     o Compress the control vector such that only ocean points are
c       written to file.
c
c     o Use a more precise nondimensionalization that depends on (x,y)
c       Added weighttype to the argument list so that I can geographically
c       vary the nondimensionalization.
c       gebbie@mit.edu, 18-Mar-2003
c
c     ==================================================================

      implicit none

c     == global variables ==

#include "EEPARAMS.h"
#include "SIZE.h"
#include "PARAMS.h"
#include "GRID.h"

#include "ctrl.h"
#include "cost.h"

#ifdef ALLOW_ECCO_OPTIMIZATION
#include "optim.h"
#endif

c     == routine arguments ==

      integer cunit
      integer ivartype
      character*( 80) fname
      character*  (5) masktype
      character*( 80) weighttype
      _RL     weightfld( nr,nsx,nsy )
      logical lxxadxx
      integer mythid

c     == local variables ==

#ifndef ALLOW_ECCO_OPTIMIZATION
      integer optimcycle
#endif

      integer bi,bj
      integer ip,jp
      integer i,j,k
      integer ii
      integer il
      integer irec
      integer itlo,ithi
      integer jtlo,jthi
      integer jmin,jmax
      integer imin,imax

      integer cbuffindex

      _RL     cbuff    ( snx*nsx*npx*sny*nsy*npy )
      _RL     globmsk  ( snx,nsx,npx,sny,nsy,npy,nr )
      _RL     globfld3d( snx,nsx,npx,sny,nsy,npy,nr )
#ifdef CTRL_PACK_PRECISE
      _RL   weightfld3d( snx,nsx,npx,sny,nsy,npy,nr )
#endif

      character*(80) weightname

c     == external ==

      integer  ilnblnk
      external ilnblnk

c     == end of interface ==

#ifndef ALLOW_ECCO_OPTIMIZATION
      optimcycle = 0
#endif

      jtlo = 1
      jthi = nsy
      itlo = 1
      ithi = nsx
      jmin = 1
      jmax = sny
      imin = 1
      imax = snx

c     Initialise temporary file
      do k = 1,nr
         do jp = 1,nPy
            do bj = jtlo,jthi
               do j = jmin,jmax
                  do ip = 1,nPx
                     do bi = itlo,ithi
                        do i = imin,imax
                           globfld3d(i,bi,ip,j,bj,jp,k) = 0. _d 0
                           globmsk  (i,bi,ip,j,bj,jp,k) = 0. _d 0
                        enddo
                     enddo
                  enddo
               enddo
            enddo
         enddo
      enddo

c--   Only the master thread will do I/O.
      _BEGIN_MASTER( mythid )

#ifdef CTRL_PACK_PRECISE
      il=ilnblnk( weighttype)
      write(weightname(1:80),'(80a)') ' '
      write(weightname(1:80),'(a)') weighttype(1:il)

      call MDSREADFIELD_3D_GL(
     &     weightname, ctrlprec, 'RL',
     &     Nr, weightfld3d, 1, mythid)
#endif

      call MDSREADFIELD_3D_GL( 
     &     masktype, ctrlprec, 'RL',
     &     Nr, globmsk, 1, mythid)

      do irec = 1, ncvarrecs(ivartype)

         call MDSREADFIELD_3D_GL( fname, ctrlprec, 'RL',
     &        Nr, globfld3d, irec, mythid)

         write(cunit) ncvarindex(ivartype)
         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
                     if (lxxadxx) then
                        cbuff(cbuffindex) = 
     &                       globfld3d(i,bi,ip,j,bj,jp,k) *
# ifdef CTRL_PACK_PRECISE
     &                       sqrt(weightfld3d(i,bi,ip,j,bj,jp,k))
# else
     &                       sqrt(weightfld(k,bi,bj))
# endif
                     else
                        cbuff(cbuffindex) = 
     &                       globfld3d(i,bi,ip,j,bj,jp,k) /
# ifdef CTRL_PACK_PRECISE
     &                       sqrt(weightfld3d(i,bi,ip,j,bj,jp,k))
# else
     &                       sqrt(weightfld(k,bi,bj))
# endif
                     endif
#else /* ALLOW_NONDIMENSIONAL_CONTROL_IO undef */
                     cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)
#endif /* ALLOW_NONDIMENSIONAL_CONTROL_IO */
                  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
c
c     -- end of irec loop --
      enddo

      _END_MASTER( mythid )

      return
      end

1	edhill	1.5	C
2	heimbach	1.6	C $Header: /u/gcmpack/MITgcm/pkg/ctrl/ctrl_set_pack_xyz.F,v 1.5 2003/10/23 04:41:40 edhill Exp $
3			C $Name: $
4	heimbach	1.2
5			#include "CTRL_CPPOPTIONS.h"
6
7
8			subroutine ctrl_set_pack_xyz(
9	heimbach	1.4	& cunit, ivartype, fname, masktype, weighttype,
10	heimbach	1.2	& weightfld, lxxadxx, mythid)
11
12			c ==================================================================
13			c SUBROUTINE ctrl_set_pack_xyz
14			c ==================================================================
15			c
16			c o Compress the control vector such that only ocean points are
17			c written to file.
18			c
19	heimbach	1.4	c o Use a more precise nondimensionalization that depends on (x,y)
20			c Added weighttype to the argument list so that I can geographically
21			c vary the nondimensionalization.
22			c gebbie@mit.edu, 18-Mar-2003
23			c
24	heimbach	1.2	c ==================================================================
25
26			implicit none
27
28			c == global variables ==
29
30			#include "EEPARAMS.h"
31			#include "SIZE.h"
32			#include "PARAMS.h"
33			#include "GRID.h"
34
35			#include "ctrl.h"
36			#include "cost.h"
37
38			#ifdef ALLOW_ECCO_OPTIMIZATION
39			#include "optim.h"
40			#endif
41
42			c == routine arguments ==
43
44			integer cunit
45			integer ivartype
46			character*( 80) fname
47			character* (5) masktype
48	heimbach	1.4	character*( 80) weighttype
49	heimbach	1.2	_RL weightfld( nr,nsx,nsy )
50			logical lxxadxx
51			integer mythid
52
53			c == local variables ==
54
55			#ifndef ALLOW_ECCO_OPTIMIZATION
56			integer optimcycle
57			#endif
58
59			integer bi,bj
60			integer ip,jp
61			integer i,j,k
62			integer ii
63			integer il
64			integer irec
65			integer itlo,ithi
66			integer jtlo,jthi
67			integer jmin,jmax
68			integer imin,imax
69
70			integer cbuffindex
71
72			_RL cbuff ( snxnsxnpxsnynsy*npy )
73			_RL globmsk ( snx,nsx,npx,sny,nsy,npy,nr )
74			_RL globfld3d( snx,nsx,npx,sny,nsy,npy,nr )
75	heimbach	1.4	#ifdef CTRL_PACK_PRECISE
76			_RL weightfld3d( snx,nsx,npx,sny,nsy,npy,nr )
77			#endif
78
79			character*(80) weightname
80	heimbach	1.2
81			c == external ==
82
83			integer ilnblnk
84			external ilnblnk
85
86			c == end of interface ==
87
88			#ifndef ALLOW_ECCO_OPTIMIZATION
89			optimcycle = 0
90			#endif
91
92			jtlo = 1
93			jthi = nsy
94			itlo = 1
95			ithi = nsx
96			jmin = 1
97			jmax = sny
98			imin = 1
99			imax = snx
100
101			c Initialise temporary file
102			do k = 1,nr
103			do jp = 1,nPy
104			do bj = jtlo,jthi
105			do j = jmin,jmax
106			do ip = 1,nPx
107			do bi = itlo,ithi
108			do i = imin,imax
109			globfld3d(i,bi,ip,j,bj,jp,k) = 0. _d 0
110			globmsk (i,bi,ip,j,bj,jp,k) = 0. _d 0
111			enddo
112			enddo
113			enddo
114			enddo
115			enddo
116			enddo
117			enddo
118
119			c-- Only the master thread will do I/O.
120			_BEGIN_MASTER( mythid )
121
122	heimbach	1.4	#ifdef CTRL_PACK_PRECISE
123			il=ilnblnk( weighttype)
124			write(weightname(1:80),'(80a)') ' '
125			write(weightname(1:80),'(a)') weighttype(1:il)
126
127			call MDSREADFIELD_3D_GL(
128			& weightname, ctrlprec, 'RL',
129			& Nr, weightfld3d, 1, mythid)
130			#endif
131
132	heimbach	1.2	call MDSREADFIELD_3D_GL(
133			& masktype, ctrlprec, 'RL',
134			& Nr, globmsk, 1, mythid)
135
136			do irec = 1, ncvarrecs(ivartype)
137
138			call MDSREADFIELD_3D_GL( fname, ctrlprec, 'RL',
139			& Nr, globfld3d, irec, mythid)
140
141			write(cunit) ncvarindex(ivartype)
142			write(cunit) 1
143			write(cunit) 1
144			do k = 1, nr
145			cbuffindex = 0
146			do jp = 1,nPy
147			do bj = jtlo,jthi
148			do j = jmin,jmax
149			do ip = 1,nPx
150			do bi = itlo,ithi
151			do i = imin,imax
152			if (globmsk(i,bi,ip,j,bj,jp,k) .ne. 0. ) then
153			cbuffindex = cbuffindex + 1
154			#ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO
155			if (lxxadxx) then
156			cbuff(cbuffindex) =
157			& globfld3d(i,bi,ip,j,bj,jp,k) *
158	heimbach	1.4	# ifdef CTRL_PACK_PRECISE
159			& sqrt(weightfld3d(i,bi,ip,j,bj,jp,k))
160			# else
161	heimbach	1.2	& sqrt(weightfld(k,bi,bj))
162	heimbach	1.4	# endif
163	heimbach	1.2	else
164			cbuff(cbuffindex) =
165			& globfld3d(i,bi,ip,j,bj,jp,k) /
166	heimbach	1.4	# ifdef CTRL_PACK_PRECISE
167			& sqrt(weightfld3d(i,bi,ip,j,bj,jp,k))
168			# else
169	heimbach	1.2	& sqrt(weightfld(k,bi,bj))
170	heimbach	1.4	# endif
171	heimbach	1.2	endif
172	heimbach	1.4	#else /* ALLOW_NONDIMENSIONAL_CONTROL_IO undef */
173	heimbach	1.2	cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)
174	heimbach	1.4	#endif /* ALLOW_NONDIMENSIONAL_CONTROL_IO */
175	heimbach	1.2	endif
176			enddo
177			enddo
178			enddo
179			enddo
180			enddo
181			enddo
182			c --> check cbuffindex.
183			if ( cbuffindex .gt. 0) then
184			write(cunit) cbuffindex
185			write(cunit) k
186			write(cunit) (cbuff(ii), ii=1,cbuffindex)
187			endif
188			enddo
189			c
190			c -- end of irec loop --
191			enddo
192
193			_END_MASTER( mythid )
194
195			return
196			end
197