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

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

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

revision 1.1.2.1 by heimbach, Tue Feb 5 20:23:58 2002 UTC revision 1.16 by jmc, Tue Sep 18 20:21:23 2012 UTC
# Line 1  Line 1 
1    C $Header$
2    C $Name$
3    
4  #include "CTRL_CPPOPTIONS.h"  #include "CTRL_OPTIONS.h"
5  #ifdef ALLOW_OBCS  #ifdef ALLOW_OBCS
6  # include "OBCS_OPTIONS.h"  # include "OBCS_OPTIONS.h"
7  #endif  #endif
8    
   
9        subroutine ctrl_getobcsw(        subroutine ctrl_getobcsw(
10       I                             mytime,       I                             mytime,
11       I                             myiter,       I                             myiter,
# Line 15  c     ================================== Line 16  c     ==================================
16  c     SUBROUTINE ctrl_getobcsw  c     SUBROUTINE ctrl_getobcsw
17  c     ==================================================================  c     ==================================================================
18  c  c
19  c     o Get norhtern obc of the control vector and add it  c     o Get western obc of the control vector and add it
20  c       to dyn. fields  c       to dyn. fields
21  c  c
22  c     started: heimbach@mit.edu, 29-Aug-2001  c     started: heimbach@mit.edu, 29-Aug-2001
23  c  c
24    c     modified: gebbie@mit.edu, 18-Mar-2003
25  c     ==================================================================  c     ==================================================================
26  c     SUBROUTINE ctrl_getobcsw  c     SUBROUTINE ctrl_getobcsw
27  c     ==================================================================  c     ==================================================================
28    
29        implicit none        implicit none
30    
 #ifdef ALLOW_OBCSW_CONTROL  
   
31  c     == global variables ==  c     == global variables ==
32    #ifdef ALLOW_OBCSW_CONTROL
33  #include "EEPARAMS.h"  #include "EEPARAMS.h"
34  #include "SIZE.h"  #include "SIZE.h"
35  #include "PARAMS.h"  #include "PARAMS.h"
36  #include "GRID.h"  #include "GRID.h"
37  #include "OBCS.h"  c#include "OBCS_PARAMS.h"
38    #include "OBCS_GRID.h"
39    #include "OBCS_FIELDS.h"
40    #include "CTRL_SIZE.h"
41  #include "ctrl.h"  #include "ctrl.h"
42  #include "ctrl_dummy.h"  #include "ctrl_dummy.h"
43  #include "optim.h"  #include "optim.h"
44    #endif /* ALLOW_OBCSW_CONTROL */
45    
46  c     == routine arguments ==  c     == routine arguments ==
   
47        _RL     mytime        _RL     mytime
48        integer myiter        integer myiter
49        integer mythid        integer mythid
50    
51    #ifdef ALLOW_OBCSW_CONTROL
52  c     == local variables ==  c     == local variables ==
53    
54        integer bi,bj        integer bi,bj
# Line 56  c     == local variables == Line 59  c     == local variables ==
59        integer imin,imax        integer imin,imax
60        integer ilobcsw        integer ilobcsw
61        integer iobcs        integer iobcs
62          integer ip1
63    
64        _RL     dummy        _RL     dummy
65        _RL     obcswfac        _RL     obcswfac
# Line 64  c     == local variables == Line 68  c     == local variables ==
68        integer obcswcount0        integer obcswcount0
69        integer obcswcount1        integer obcswcount1
70    
71        _RL maskyz   (1-oly:sny+oly,nr,nsx,nsy)  cgg      _RL maskyz   (1-oly:sny+oly,nr,nsx,nsy)
72          _RL tmpfldyz (1-oly:sny+oly,nr,nsx,nsy)
73    
74        logical doglobalread        logical doglobalread
75        logical ladinit        logical ladinit
76    
77        character*(80) fnameobcsw        character*(80) fnameobcsw
78    
79          #ifdef ALLOW_OBCS_CONTROL_MODES
80          integer nk,nz
81          _RL     tmpz (nr,nsx,nsy)
82          _RL     stmp
83    #endif
84    
85  c     == external functions ==  c     == external functions ==
86    
# Line 89  c     == end of interface == Line 98  c     == end of interface ==
98        jmax = sny+oly        jmax = sny+oly
99        imin = 1-olx        imin = 1-olx
100        imax = snx+olx        imax = snx+olx
101          ip1  = 1
102    
103  c--   Now, read the control vector.  c--   Now, read the control vector.
104        doglobalread = .false.        doglobalread = .false.
105        ladinit      = .false.        ladinit      = .false.
106    
107        if (optimcycle .ge. 0) then        if (optimcycle .ge. 0) then
108          ilobcsw=ilnblnk( xx_obcsw_file )         ilobcsw=ilnblnk( xx_obcsw_file )
109          write(fnameobcsw(1:80),'(2a,i10.10)')         write(fnameobcsw(1:80),'(2a,i10.10)')
110       &       xx_obcsw_file(1:ilobcsw), '.', optimcycle       &      xx_obcsw_file(1:ilobcsw), '.', optimcycle
       else  
         print*  
         print*,' ctrl_getobcsw: optimcycle not set correctly.'  
         print*,' ... stopped in ctrl_getobcsw.'  
111        endif        endif
112    
113  c--   Get the counters, flags, and the interpolation factor.  c--   Get the counters, flags, and the interpolation factor.
114        call ctrl_GetRec( 'xx_obcsw',        call ctrl_get_gen_rec(
115         I                   xx_obcswstartdate, xx_obcswperiod,
116       O                   obcswfac, obcswfirst, obcswchanged,       O                   obcswfac, obcswfirst, obcswchanged,
117       O                   obcswcount0,obcswcount1,       O                   obcswcount0,obcswcount1,
118       I                   mytime, myiter, mythid )       I                   mytime, myiter, mythid )
119    
120        do iobcs = 1,nobcs        do iobcs = 1,nobcs
121           if ( obcswfirst ) then
122          call active_read_yz( 'maskobcsw', maskyz,          call active_read_yz( fnameobcsw, tmpfldyz,
      &                       iobcs,  
      &                       doglobalread, ladinit, 0,  
      &                       mythid, dummy )  
   
         call active_read_yz( fnameobcsw, tmpfldyz,  
123       &                       (obcswcount0-1)*nobcs+iobcs,       &                       (obcswcount0-1)*nobcs+iobcs,
124       &                       doglobalread, ladinit, optimcycle,       &                       doglobalread, ladinit, optimcycle,
125       &                       mythid, xx_obcsw_dummy )       &                       mythid, xx_obcsw_dummy )
126    
127          do bj = jtlo,jthi          do bj = jtlo,jthi
128            do bi = itlo,ithi           do bi = itlo,ithi
129              do k = 1,nr  #ifdef ALLOW_OBCS_CONTROL_MODES
130                do j = jmin,jmax            if (iobcs .gt. 2) then
131                  yz_obcs0(j,k,bi,bj)  = tmpfldyz (j,k,bi,bj)             do j = jmin,jmax
132                enddo              i = OB_Iw(j,bi,bj)
133                IF ( i.EQ.OB_indexNone ) i = 1
134    cih    Determine number of open vertical layers.
135                nz = 0
136                do k = 1,Nr
137                  if (iobcs .eq. 3) then
138                    nz = nz + maskW(i+ip1,j,k,bi,bj)
139                  else
140                    nz = nz + maskS(i,j,k,bi,bj)
141                  endif
142                end do
143    cih    Compute absolute velocities from the barotropic-baroclinic modes.
144                do k = 1,Nr
145                 if (k.le.nz) then
146                  stmp = 0.
147                  do nk = 1,nz
148                   stmp = stmp +
149         &         modesv(k,nk,nz)*tmpfldyz(j,nk,bi,bj)
150                  end do
151                   tmpz(k,bi,bj) = stmp
152                 else
153                  tmpz(k,bi,bj) = 0.
154                 end if
155              enddo              enddo
156                do k = 1,Nr
157                  if (iobcs .eq. 3) then
158                    tmpfldyz(j,k,bi,bj) = tmpz(k,bi,bj)
159         &            *recip_hFacW(i+ip1,j,k,bi,bj)
160                  else
161                    tmpfldyz(j,k,bi,bj) = tmpz(k,bi,bj)
162         &            *recip_hFacS(i,j,k,bi,bj)
163                  endif
164                end do
165               enddo
166              endif
167    #endif
168              do k = 1,nr
169               do j = jmin,jmax
170                xx_obcsw1(j,k,bi,bj,iobcs)  = tmpfldyz (j,k,bi,bj)
171    cgg   &                                        *   maskyz (j,k,bi,bj)
172               enddo
173              enddo
174             enddo
175            enddo
176           endif
177    
178           if ( (obcswfirst) .or. (obcswchanged)) then
179    
180            do bj = jtlo,jthi
181             do bi = itlo,ithi
182              do k = 1,nr
183               do j = jmin,jmax
184                xx_obcsw0(j,k,bi,bj,iobcs) = xx_obcsw1(j,k,bi,bj,iobcs)
185                tmpfldyz (j,k,bi,bj)       = 0. _d 0
186               enddo
187            enddo            enddo
188             enddo
189          enddo          enddo
190    
191          call active_read_yz( fnameobcsw, tmpfldyz,          call active_read_yz( fnameobcsw, tmpfldyz,
192       &                       (obcswcount1-1)*nobcs+iobcs,       &                       (obcswcount1-1)*nobcs+iobcs,
193       &                       doglobalread, ladinit, optimcycle,       &                       doglobalread, ladinit, optimcycle,
194       &                       mythid, xx_obcsw_dummy )       &                       mythid, xx_obcsw_dummy )
195    
196          do bj = jtlo,jthi          do bj = jtlo,jthi
197            do bi = itlo,ithi           do bi = itlo,ithi
198              do k = 1,nr  #ifdef ALLOW_OBCS_CONTROL_MODES
199                do j = jmin,jmax            if (iobcs .gt. 2) then
200                  yz_obcs1 (j,k,bi,bj) = tmpfldyz (j,k,bi,bj)             do j = jmin,jmax
201                enddo              i = OB_Iw(j,bi,bj)
202                IF ( i.EQ.OB_indexNone ) i = 1
203    cih    Determine number of open vertical layers.
204                nz = 0
205                do k = 1,Nr
206                  if (iobcs .eq. 3) then
207                    nz = nz + maskW(i+ip1,j,k,bi,bj)
208                  else
209                    nz = nz + maskS(i,j,k,bi,bj)
210                  endif
211                end do
212    cih    Compute absolute velocities from the barotropic-baroclinic modes.
213                do k = 1,Nr
214                 if (k.le.nz) then
215                  stmp = 0.
216                  do nk = 1,nz
217                   stmp = stmp +
218         &         modesv(k,nk,nz)*tmpfldyz(j,nk,bi,bj)
219                  end do
220                   tmpz(k,bi,bj) = stmp
221                 else
222                   tmpz(k,bi,bj) = 0.
223                 end if
224              enddo              enddo
225                do k = 1,Nr
226                  if (iobcs .eq. 3) then
227                    tmpfldyz(j,k,bi,bj) = tmpz(k,bi,bj)
228         &            *recip_hFacW(i+ip1,j,k,bi,bj)
229                  else
230                    tmpfldyz(j,k,bi,bj) = tmpz(k,bi,bj)
231         &            *recip_hFacS(i,j,k,bi,bj)
232                  endif
233                end do
234               enddo
235              endif
236    #endif
237              do k = 1,nr
238               do j = jmin,jmax
239                xx_obcsw1 (j,k,bi,bj,iobcs) = tmpfldyz (j,k,bi,bj)
240    cgg   &                                        *   maskyz (j,k,bi,bj)
241               enddo
242            enddo            enddo
243             enddo
244          enddo          enddo
245           endif
246    
247  c--     Add control to model variable.  c--   Add control to model variable.
248          do bj = jtlo,jthi         do bj = jtlo, jthi
249             do bi = itlo,ithi          do bi = itlo, ithi
250  c--        Calculate mask for tracer cells (0 => land, 1 => water).  c--   Calculate mask for tracer cells (0 => land, 1 => water).
251                do k = 1,nr           do k = 1,nr
252                   do j = 1,sny            do j = 1,sny
253                      if (iobcs .EQ. 1) then             i = OB_Iw(j,bi,bj)
254                         OBWt(j,k,bi,bj) = OBWt (j,k,bi,bj)             IF ( i.EQ.OB_indexNone ) i = 1
255       &                      + obcswfac            *yz_obcs0(j,k,bi,bj)             if (iobcs .EQ. 1) then
256       &                      + (1. _d 0 - obcswfac)*yz_obcs1(j,k,bi,bj)              OBWt(j,k,bi,bj) = OBWt (j,k,bi,bj)
257                         OBWt(j,k,bi,bj) = OBWt(j,k,bi,bj)       &           + obcswfac            *xx_obcsw0(j,k,bi,bj,iobcs)
258       &                      *maskyz(j,k,bi,bj)       &           + (1. _d 0 - obcswfac)*xx_obcsw1(j,k,bi,bj,iobcs)
259                      else if (iobcs .EQ. 2) then              OBWt(j,k,bi,bj) = OBWt(j,k,bi,bj)
260                         OBWs(j,k,bi,bj) = OBWs (j,k,bi,bj)       &           *maskW(i+ip1,j,k,bi,bj)
261       &                      + obcswfac            *yz_obcs0(j,k,bi,bj)             else if (iobcs .EQ. 2) then
262       &                      + (1. _d 0 - obcswfac)*yz_obcs1(j,k,bi,bj)              OBWs(j,k,bi,bj) = OBWs (j,k,bi,bj)
263                         OBWs(j,k,bi,bj) = OBWs(j,k,bi,bj)       &           + obcswfac            *xx_obcsw0(j,k,bi,bj,iobcs)
264       &                      *maskyz(j,k,bi,bj)       &           + (1. _d 0 - obcswfac)*xx_obcsw1(j,k,bi,bj,iobcs)
265                      else if (iobcs .EQ. 3) then              OBWs(j,k,bi,bj) = OBWs(j,k,bi,bj)
266                         OBWu(j,k,bi,bj) = OBWu (j,k,bi,bj)       &           *maskW(i+ip1,j,k,bi,bj)
267       &                      + obcswfac            *yz_obcs0(j,k,bi,bj)             else if (iobcs .EQ. 3) then
268       &                      + (1. _d 0 - obcswfac)*yz_obcs1(j,k,bi,bj)              OBWu(j,k,bi,bj) = OBWu (j,k,bi,bj)
269                         OBWu(j,k,bi,bj) = OBWu(j,k,bi,bj)       &           + obcswfac            *xx_obcsw0(j,k,bi,bj,iobcs)
270       &                      *maskyz(j,k,bi,bj)       &           + (1. _d 0 - obcswfac)*xx_obcsw1(j,k,bi,bj,iobcs)
271                      else if (iobcs .EQ. 4) then              OBWu(j,k,bi,bj) = OBWu(j,k,bi,bj)
272                         OBWv(j,k,bi,bj) = OBWv (j,k,bi,bj)       &           *maskW(i+ip1,j,k,bi,bj)
273       &                      + obcswfac            *yz_obcs0(j,k,bi,bj)             else if (iobcs .EQ. 4) then
274       &                      + (1. _d 0 - obcswfac)*yz_obcs1(j,k,bi,bj)              OBWv(j,k,bi,bj) = OBWv (j,k,bi,bj)
275                         OBWv(j,k,bi,bj) = OBWv(j,k,bi,bj)       &           + obcswfac            *xx_obcsw0(j,k,bi,bj,iobcs)
276       &                      *maskyz(j,k,bi,bj)       &           + (1. _d 0 - obcswfac)*xx_obcsw1(j,k,bi,bj,iobcs)
277                      endif              OBWv(j,k,bi,bj) = OBWv(j,k,bi,bj)
278                   enddo       &           *maskS(i,j,k,bi,bj)
279                enddo             endif
280             enddo            enddo
281             enddo
282          enddo          enddo
283           enddo
284    
285  C--   End over iobcs loop  C--   End over iobcs loop
286        enddo        enddo
287    
 #else /* ALLOW_OBCSW_CONTROL undefined */  
   
 c     == routine arguments ==  
   
       _RL     mytime  
       integer myiter  
       integer mythid  
   
 c--   CPP flag ALLOW_OBCSW_CONTROL undefined.  
   
288  #endif /* ALLOW_OBCSW_CONTROL */  #endif /* ALLOW_OBCSW_CONTROL */
289    
290          return
291        end        end
   
Legend:
Removed from v.1.1.2.1  
changed lines
  Added in v.1.16
  ViewVC Help
Powered by ViewVC 1.1.22