/[MITgcm]/MITgcm_contrib/heimbach/ice_only_estimation/code_ref/cg2d.F
ViewVC logotype

Contents of /MITgcm_contrib/heimbach/ice_only_estimation/code_ref/cg2d.F

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


Revision 1.1 - (show annotations) (download)
Sat Sep 3 12:01:23 2005 UTC (21 years ago) by heimbach
Branch: MAIN
CVS Tags: HEAD
A seaice-only (no ocean) config. for 1x1 deg. Lab. Sea

1 C $Header: /u/gcmpack/MITgcm/model/src/cg2d.F,v 1.43 2005/02/09 21:12:40 heimbach Exp $
2 C $Name: $
3
4 #include "CPP_OPTIONS.h"
5
6 CBOP
7 C !ROUTINE: CG2D
8 C !INTERFACE:
9 SUBROUTINE CG2D(
10 I cg2d_b,
11 U cg2d_x,
12 O firstResidual,
13 O lastResidual,
14 U numIters,
15 I myThid )
16 C !DESCRIPTION: \bv
17 C *==========================================================*
18 C | SUBROUTINE CG2D
19 C | o Two-dimensional grid problem conjugate-gradient
20 C | inverter (with preconditioner).
21 C *==========================================================*
22 C | Con. grad is an iterative procedure for solving Ax = b.
23 C | It requires the A be symmetric.
24 C | This implementation assumes A is a five-diagonal
25 C | matrix of the form that arises in the discrete
26 C | representation of the del^2 operator in a
27 C | two-dimensional space.
28 C | Notes:
29 C | ======
30 C | This implementation can support shared-memory
31 C | multi-threaded execution. In order to do this COMMON
32 C | blocks are used for many of the arrays - even ones that
33 C | are only used for intermedaite results. This design is
34 C | OK if you want to all the threads to collaborate on
35 C | solving the same problem. On the other hand if you want
36 C | the threads to solve several different problems
37 C | concurrently this implementation will not work.
38 C *==========================================================*
39 C \ev
40
41 C !USES:
42 IMPLICIT NONE
43 C === Global data ===
44 #include "SIZE.h"
45 #include "EEPARAMS.h"
46 #include "PARAMS.h"
47 #include "GRID.h"
48 #include "CG2D.h"
49 #include "SURFACE.h"
50
51 C !INPUT/OUTPUT PARAMETERS:
52 C === Routine arguments ===
53 C myThid - Thread on which I am working.
54 C cg2d_b - The source term or "right hand side"
55 C cg2d_x - The solution
56 C firstResidual - the initial residual before any iterations
57 C lastResidual - the actual residual reached
58 C numIters - Entry: the maximum number of iterations allowed
59 C Exit: the actual number of iterations used
60 _RL cg2d_b(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
61 _RL cg2d_x(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
62 _RL firstResidual
63 _RL lastResidual
64 INTEGER numIters
65 INTEGER myThid
66
67 C !LOCAL VARIABLES:
68 C === Local variables ====
69 C actualIts - Number of iterations taken
70 C actualResidual - residual
71 C bi - Block index in X and Y.
72 C bj
73 C eta_qrN - Used in computing search directions
74 C eta_qrNM1 suffix N and NM1 denote current and
75 C cgBeta previous iterations respectively.
76 C alpha
77 C sumRHS - Sum of right-hand-side. Sometimes this is a
78 C useful debuggin/trouble shooting diagnostic.
79 C For neumann problems sumRHS needs to be ~0.
80 C or they converge at a non-zero residual.
81 C err - Measure of residual of Ax - b, usually the norm.
82 C I, J, N - Loop counters ( N counts CG iterations )
83 INTEGER actualIts
84 _RL actualResidual
85 INTEGER bi, bj
86 INTEGER I, J, it2d
87 _RL err,errTile
88 _RL eta_qrN,eta_qrNtile
89 _RL eta_qrNM1
90 _RL cgBeta
91 _RL alpha,alphaTile
92 _RL sumRHS,sumRHStile
93 _RL rhsMax
94 _RL rhsNorm
95
96 INTEGER OLw
97 INTEGER OLe
98 INTEGER OLn
99 INTEGER OLs
100 INTEGER exchWidthX
101 INTEGER exchWidthY
102 INTEGER myNz
103 CEOP
104
105
106 CcnhDebugStarts
107 C CHARACTER*(MAX_LEN_FNAM) suff
108 CcnhDebugEnds
109
110
111 C-- Initialise inverter
112 eta_qrNM1 = 1. _d 0
113
114 CcnhDebugStarts
115 C _EXCH_XY_R8( cg2d_b, myThid )
116 C CALL PLOT_FIELD_XYRL( cg2d_b, 'CG2D.0 CG2D_B' , 1, myThid )
117 C suff = 'unnormalised'
118 C CALL WRITE_FLD_XY_RL ( 'cg2d_b.',suff, cg2d_b, 1, myThid)
119 C STOP
120 CcnhDebugEnds
121
122 C-- Normalise RHS
123 rhsMax = 0. _d 0
124 DO bj=myByLo(myThid),myByHi(myThid)
125 DO bi=myBxLo(myThid),myBxHi(myThid)
126 DO J=1,sNy
127 DO I=1,sNx
128 cg2d_b(I,J,bi,bj) = cg2d_b(I,J,bi,bj)*cg2dNorm
129 rhsMax = MAX(ABS(cg2d_b(I,J,bi,bj)),rhsMax)
130 ENDDO
131 ENDDO
132 ENDDO
133 ENDDO
134
135 IF (cg2dNormaliseRHS) THEN
136 C- Normalise RHS :
137 #ifdef LETS_MAKE_JAM
138 C _GLOBAL_MAX_R8( rhsMax, myThid )
139 rhsMax=1.
140 #else
141 _GLOBAL_MAX_R8( rhsMax, myThid )
142 Catm rhsMax=1.
143 #endif
144 rhsNorm = 1. _d 0
145 IF ( rhsMax .NE. 0. ) rhsNorm = 1. _d 0 / rhsMax
146 DO bj=myByLo(myThid),myByHi(myThid)
147 DO bi=myBxLo(myThid),myBxHi(myThid)
148 DO J=1,sNy
149 DO I=1,sNx
150 cg2d_b(I,J,bi,bj) = cg2d_b(I,J,bi,bj)*rhsNorm
151 cg2d_x(I,J,bi,bj) = cg2d_x(I,J,bi,bj)*rhsNorm
152 ENDDO
153 ENDDO
154 ENDDO
155 ENDDO
156 C- end Normalise RHS
157 ENDIF
158
159 C-- Update overlaps
160 _EXCH_XY_R8( cg2d_b, myThid )
161 _EXCH_XY_R8( cg2d_x, myThid )
162 CcnhDebugStarts
163 C CALL PLOT_FIELD_XYRL( cg2d_b, 'CG2D.1 CG2D_B' , 1, myThid )
164 C suff = 'normalised'
165 C CALL WRITE_FLD_XY_RL ( 'cg2d_b.',suff, cg2d_b, 1, myThid)
166 CcnhDebugEnds
167
168 C-- Initial residual calculation
169 err = 0. _d 0
170 sumRHS = 0. _d 0
171 DO bj=myByLo(myThid),myByHi(myThid)
172 DO bi=myBxLo(myThid),myBxHi(myThid)
173 sumRHStile = 0. _d 0
174 errTile = 0. _d 0
175 DO J=1,sNy
176 DO I=1,sNx
177 cg2d_s(I,J,bi,bj) = 0.
178 cg2d_r(I,J,bi,bj) = cg2d_b(I,J,bi,bj) -
179 & (aW2d(I ,J ,bi,bj)*cg2d_x(I-1,J ,bi,bj)
180 & +aW2d(I+1,J ,bi,bj)*cg2d_x(I+1,J ,bi,bj)
181 & +aS2d(I ,J ,bi,bj)*cg2d_x(I ,J-1,bi,bj)
182 & +aS2d(I ,J+1,bi,bj)*cg2d_x(I ,J+1,bi,bj)
183 & -aW2d(I ,J ,bi,bj)*cg2d_x(I ,J ,bi,bj)
184 & -aW2d(I+1,J ,bi,bj)*cg2d_x(I ,J ,bi,bj)
185 & -aS2d(I ,J ,bi,bj)*cg2d_x(I ,J ,bi,bj)
186 & -aS2d(I ,J+1,bi,bj)*cg2d_x(I ,J ,bi,bj)
187 & -freeSurfFac*_rA(i,j,bi,bj)*recip_Bo(i,j,bi,bj)*
188 & cg2d_x(I ,J ,bi,bj)/deltaTMom/deltaTfreesurf*cg2dNorm
189 & )
190 errTile = errTile +
191 & cg2d_r(I,J,bi,bj)*cg2d_r(I,J,bi,bj)
192 sumRHStile = sumRHStile +
193 & cg2d_b(I,J,bi,bj)
194 ENDDO
195 ENDDO
196 sumRHS = sumRHS + sumRHStile
197 err = err + errTile
198 ENDDO
199 ENDDO
200 C _EXCH_XY_R8( cg2d_r, myThid )
201 #ifdef LETS_MAKE_JAM
202 CALL EXCH_XY_O1_R8_JAM( cg2d_r )
203 #else
204 CALL EXCH_XY_RL( cg2d_r, myThid )
205 #endif
206 C _EXCH_XY_R8( cg2d_s, myThid )
207 #ifdef LETS_MAKE_JAM
208 CALL EXCH_XY_O1_R8_JAM( cg2d_s )
209 #else
210 CALL EXCH_XY_RL( cg2d_s, myThid )
211 #endif
212 _GLOBAL_SUM_R8( sumRHS, myThid )
213 _GLOBAL_SUM_R8( err , myThid )
214 err = SQRT(err)
215
216 IF ( debugLevel .GE. debLevZero ) THEN
217 _BEGIN_MASTER( myThid )
218 write(standardmessageunit,'(A,1P2E22.14)')
219 & ' cg2d: Sum(rhs),rhsMax = ',
220 & sumRHS,rhsMax
221 write(standardmessageunit,'(A,I6,1PE30.14)')
222 & ' CG2D iters, err = ',
223 & actualIts, actualResidual
224 _END_MASTER( myThid )
225 ENDIF
226
227 c _BARRIER
228 c _BEGIN_MASTER( myThid )
229 c WRITE(standardmessageunit,'(A,I6,1PE30.14)')
230 c & ' CG2D iters, err = ',
231 c & actualIts, actualResidual
232 c _END_MASTER( myThid )
233
234 actualIts = 0
235 actualResidual = err
236 firstResidual=actualResidual
237
238 IF ( err .LT. cg2dTolerance ) GOTO 11
239
240 C >>>>>>>>>>>>>>> BEGIN SOLVER <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
241 DO 10 it2d=1, numIters
242
243 CcnhDebugStarts
244 c WRITE(standardmessageunit,*)
245 c & ' CG2D: Iteration ',it2d-1,' residual = ',
246 c & actualResidual
247 CcnhDebugEnds
248 C-- Solve preconditioning equation and update
249 C-- conjugate direction vector "s".
250 eta_qrN = 0. _d 0
251 DO bj=myByLo(myThid),myByHi(myThid)
252 DO bi=myBxLo(myThid),myBxHi(myThid)
253 eta_qrNtile = 0. _d 0
254 DO J=1,sNy
255 DO I=1,sNx
256 cg2d_q(I,J,bi,bj) =
257 & pC(I ,J ,bi,bj)*cg2d_r(I ,J ,bi,bj)
258 & +pW(I ,J ,bi,bj)*cg2d_r(I-1,J ,bi,bj)
259 & +pW(I+1,J ,bi,bj)*cg2d_r(I+1,J ,bi,bj)
260 & +pS(I ,J ,bi,bj)*cg2d_r(I ,J-1,bi,bj)
261 & +pS(I ,J+1,bi,bj)*cg2d_r(I ,J+1,bi,bj)
262 CcnhDebugStarts
263 C cg2d_q(I,J,bi,bj) = cg2d_r(I ,J ,bi,bj)
264 CcnhDebugEnds
265 eta_qrNtile = eta_qrNtile
266 & +cg2d_q(I,J,bi,bj)*cg2d_r(I,J,bi,bj)
267 ENDDO
268 ENDDO
269 eta_qrN = eta_qrN + eta_qrNtile
270 ENDDO
271 ENDDO
272
273 _GLOBAL_SUM_R8(eta_qrN, myThid)
274 CcnhDebugStarts
275 C WRITE(*,*) ' CG2D: Iteration ',it2d-1,' eta_qrN = ',eta_qrN
276 CcnhDebugEnds
277 cgBeta = eta_qrN/eta_qrNM1
278 CcnhDebugStarts
279 C WRITE(*,*) ' CG2D: Iteration ',it2d-1,' beta = ',cgBeta
280 CcnhDebugEnds
281 eta_qrNM1 = eta_qrN
282
283 DO bj=myByLo(myThid),myByHi(myThid)
284 DO bi=myBxLo(myThid),myBxHi(myThid)
285 DO J=1,sNy
286 DO I=1,sNx
287 cg2d_s(I,J,bi,bj) = cg2d_q(I,J,bi,bj)
288 & + cgBeta*cg2d_s(I,J,bi,bj)
289 ENDDO
290 ENDDO
291 ENDDO
292 ENDDO
293
294 C-- Do exchanges that require messages i.e. between
295 C-- processes.
296 C _EXCH_XY_R8( cg2d_s, myThid )
297 #ifdef LETS_MAKE_JAM
298 CALL EXCH_XY_O1_R8_JAM( cg2d_s )
299 #else
300 CALL EXCH_XY_RL( cg2d_s, myThid )
301 #endif
302
303 C== Evaluate laplace operator on conjugate gradient vector
304 C== q = A.s
305 alpha = 0. _d 0
306 DO bj=myByLo(myThid),myByHi(myThid)
307 DO bi=myBxLo(myThid),myBxHi(myThid)
308 alphaTile = 0. _d 0
309 DO J=1,sNy
310 DO I=1,sNx
311 cg2d_q(I,J,bi,bj) =
312 & aW2d(I ,J ,bi,bj)*cg2d_s(I-1,J ,bi,bj)
313 & +aW2d(I+1,J ,bi,bj)*cg2d_s(I+1,J ,bi,bj)
314 & +aS2d(I ,J ,bi,bj)*cg2d_s(I ,J-1,bi,bj)
315 & +aS2d(I ,J+1,bi,bj)*cg2d_s(I ,J+1,bi,bj)
316 & -aW2d(I ,J ,bi,bj)*cg2d_s(I ,J ,bi,bj)
317 & -aW2d(I+1,J ,bi,bj)*cg2d_s(I ,J ,bi,bj)
318 & -aS2d(I ,J ,bi,bj)*cg2d_s(I ,J ,bi,bj)
319 & -aS2d(I ,J+1,bi,bj)*cg2d_s(I ,J ,bi,bj)
320 & -freeSurfFac*_rA(i,j,bi,bj)*recip_Bo(i,j,bi,bj)*
321 & cg2d_s(I ,J ,bi,bj)/deltaTMom/deltaTfreesurf*cg2dNorm
322 alphaTile = alphaTile+cg2d_s(I,J,bi,bj)*cg2d_q(I,J,bi,bj)
323 ENDDO
324 ENDDO
325 alpha = alpha + alphaTile
326 ENDDO
327 ENDDO
328 _GLOBAL_SUM_R8(alpha,myThid)
329 CcnhDebugStarts
330 C WRITE(*,*) ' CG2D: Iteration ',it2d-1,' SUM(s*q)= ',alpha
331 CcnhDebugEnds
332 alpha = eta_qrN/alpha
333 CcnhDebugStarts
334 C WRITE(*,*) ' CG2D: Iteration ',it2d-1,' alpha= ',alpha
335 CcnhDebugEnds
336
337 C== Update solution and residual vectors
338 C Now compute "interior" points.
339 err = 0. _d 0
340 DO bj=myByLo(myThid),myByHi(myThid)
341 DO bi=myBxLo(myThid),myBxHi(myThid)
342 errTile = 0. _d 0
343 DO J=1,sNy
344 DO I=1,sNx
345 cg2d_x(I,J,bi,bj)=cg2d_x(I,J,bi,bj)+alpha*cg2d_s(I,J,bi,bj)
346 cg2d_r(I,J,bi,bj)=cg2d_r(I,J,bi,bj)-alpha*cg2d_q(I,J,bi,bj)
347 errTile = errTile+cg2d_r(I,J,bi,bj)*cg2d_r(I,J,bi,bj)
348 ENDDO
349 ENDDO
350 err = err + errTile
351 ENDDO
352 ENDDO
353
354 _GLOBAL_SUM_R8( err , myThid )
355 err = SQRT(err)
356 actualIts = it2d
357 actualResidual = err
358 IF ( err .LT. cg2dTolerance ) GOTO 11
359 C _EXCH_XY_R8(cg2d_r, myThid )
360 #ifdef LETS_MAKE_JAM
361 CALL EXCH_XY_O1_R8_JAM( cg2d_r )
362 #else
363 CALL EXCH_XY_RL( cg2d_r, myThid )
364 #endif
365
366 10 CONTINUE
367 11 CONTINUE
368
369 IF (cg2dNormaliseRHS) THEN
370 C-- Un-normalise the answer
371 DO bj=myByLo(myThid),myByHi(myThid)
372 DO bi=myBxLo(myThid),myBxHi(myThid)
373 DO J=1,sNy
374 DO I=1,sNx
375 cg2d_x(I ,J ,bi,bj) = cg2d_x(I ,J ,bi,bj)/rhsNorm
376 ENDDO
377 ENDDO
378 ENDDO
379 ENDDO
380 ENDIF
381
382 C The following exchange was moved up to solve_for_pressure
383 C for compatibility with TAMC.
384 C _EXCH_XY_R8(cg2d_x, myThid )
385 c _BEGIN_MASTER( myThid )
386 c WRITE(*,'(A,I6,1PE30.14)') ' CG2D iters, err = ',
387 c & actualIts, actualResidual
388 c _END_MASTER( myThid )
389
390 c write(standardmessageunit,'(A,I6,1PE30.14)') '
391 c & CG2D iters, err = ',
392 c & actualIts, actualResidual
393
394 C-- Return parameters to caller
395 lastResidual=actualResidual
396 numIters=actualIts
397
398 CcnhDebugStarts
399 C CALL PLOT_FIELD_XYRL( cg2d_x, 'CALC_MOM_RHS CG2D_X' , 1, myThid )
400 C err = 0. _d 0
401 C DO bj=myByLo(myThid),myByHi(myThid)
402 C DO bi=myBxLo(myThid),myBxHi(myThid)
403 C DO J=1,sNy
404 C DO I=1,sNx
405 C cg2d_r(I,J,bi,bj) = cg2d_b(I,J,bi,bj) -
406 C & (aW2d(I ,J ,bi,bj)*cg2d_x(I-1,J ,bi,bj)
407 C & +aW2d(I+1,J ,bi,bj)*cg2d_x(I+1,J ,bi,bj)
408 C & +aS2d(I ,J ,bi,bj)*cg2d_x(I ,J-1,bi,bj)
409 C & +aS2d(I ,J+1,bi,bj)*cg2d_x(I ,J+1,bi,bj)
410 C & -aW2d(I ,J ,bi,bj)*cg2d_x(I ,J ,bi,bj)
411 C & -aW2d(I+1,J ,bi,bj)*cg2d_x(I ,J ,bi,bj)
412 C & -aS2d(I ,J ,bi,bj)*cg2d_x(I ,J ,bi,bj)
413 C & -aS2d(I ,J+1,bi,bj)*cg2d_x(I ,J ,bi,bj))
414 C err = err +
415 C & cg2d_r(I,J,bi,bj)*cg2d_r(I,J,bi,bj)
416 C ENDDO
417 C ENDDO
418 C ENDDO
419 C ENDDO
420 C _GLOBAL_SUM_R8( err , myThid )
421 C write(*,*) 'cg2d: Ax - b = ',SQRT(err)
422 CcnhDebugEnds
423
424 RETURN
425 END

  ViewVC Help
Powered by ViewVC 1.1.22