1;;; Compiled by f2cl version:
2;;; ("f2cl1.l,v 1.221 2010/05/26 19:25:52 rtoy Exp $"
3;;;  "f2cl2.l,v 1.37 2008/02/22 22:19:33 rtoy Exp $"
4;;;  "f2cl3.l,v 1.6 2008/02/22 22:19:33 rtoy Exp $"
5;;;  "f2cl4.l,v 1.7 2008/02/22 22:19:34 rtoy Exp $"
6;;;  "f2cl5.l,v 1.204 2010/02/23 05:21:30 rtoy Exp $"
7;;;  "f2cl6.l,v 1.48 2008/08/24 00:56:27 rtoy Exp $"
8;;;  "macros.l,v 1.114 2010/05/17 01:42:14 rtoy Exp $")
9
10;;; Using Lisp CMU Common Lisp CVS Head 2010-05-25 18:21:07 (20A Unicode)
11;;;
12;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
13;;;           (:coerce-assigns :as-needed) (:array-type ':array)
14;;;           (:array-slicing t) (:declare-common nil)
15;;;           (:float-format double-float))
16
17(in-package :colnew)
18
19
20(defun contrl
21       (xi xiold z dmz rhs delz deldmz dqz dqdmz g w v valstr slope scale
22        dscale accum ipvtg integs ipvtw nfxpnt fixpnt iflag fsub dfsub gsub
23        dgsub guess)
24  (declare (type (f2cl-lib:integer4) iflag nfxpnt)
25           (type (array f2cl-lib:integer4 (*)) ipvtw integs ipvtg)
26           (type (array double-float (*)) fixpnt accum dscale scale slope
27                                          valstr v w g dqdmz dqz deldmz delz
28                                          rhs dmz z xiold xi))
29  (let ((colest-tolin
30         (make-array 40
31                     :element-type 'double-float
32                     :displaced-to (colest-part-0 *colest-common-block*)
33                     :displaced-index-offset 120))
34        (colest-ltol
35         (make-array 40
36                     :element-type 'f2cl-lib:integer4
37                     :displaced-to (colest-part-1 *colest-common-block*)
38                     :displaced-index-offset 40)))
39    (symbol-macrolet ((precis (aref (colout-part-0 *colout-common-block*) 0))
40                      (iout (aref (colout-part-1 *colout-common-block*) 0))
41                      (iprint (aref (colout-part-1 *colout-common-block*) 1))
42                      (mstar (aref (colord-part-0 *colord-common-block*) 2))
43                      (kd (aref (colord-part-0 *colord-common-block*) 3))
44                      (n (aref (colapr-part-0 *colapr-common-block*) 0))
45                      (nold (aref (colapr-part-0 *colapr-common-block*) 1))
46                      (nmax (aref (colapr-part-0 *colapr-common-block*) 2))
47                      (nz (aref (colapr-part-0 *colapr-common-block*) 3))
48                      (ndmz (aref (colapr-part-0 *colapr-common-block*) 4))
49                      (mshnum (aref (colmsh-part-0 *colmsh-common-block*) 1))
50                      (mshlmt (aref (colmsh-part-0 *colmsh-common-block*) 2))
51                      (mshalt (aref (colmsh-part-0 *colmsh-common-block*) 3))
52                      (nonlin (aref (colnln-part-0 *colnln-common-block*) 0))
53                      (iter (aref (colnln-part-0 *colnln-common-block*) 1))
54                      (limit (aref (colnln-part-0 *colnln-common-block*) 2))
55                      (icare (aref (colnln-part-0 *colnln-common-block*) 3))
56                      (iguess (aref (colnln-part-0 *colnln-common-block*) 4))
57                      (tolin colest-tolin)
58                      (ltol colest-ltol)
59                      (ntol (aref (colest-part-1 *colest-common-block*) 80)))
60      (f2cl-lib:with-multi-array-data
61          ((xi double-float xi-%data% xi-%offset%)
62           (xiold double-float xiold-%data% xiold-%offset%)
63           (z double-float z-%data% z-%offset%)
64           (dmz double-float dmz-%data% dmz-%offset%)
65           (rhs double-float rhs-%data% rhs-%offset%)
66           (delz double-float delz-%data% delz-%offset%)
67           (deldmz double-float deldmz-%data% deldmz-%offset%)
68           (dqz double-float dqz-%data% dqz-%offset%)
69           (dqdmz double-float dqdmz-%data% dqdmz-%offset%)
70           (g double-float g-%data% g-%offset%)
71           (w double-float w-%data% w-%offset%)
72           (v double-float v-%data% v-%offset%)
73           (valstr double-float valstr-%data% valstr-%offset%)
74           (slope double-float slope-%data% slope-%offset%)
75           (scale double-float scale-%data% scale-%offset%)
76           (dscale double-float dscale-%data% dscale-%offset%)
77           (accum double-float accum-%data% accum-%offset%)
78           (fixpnt double-float fixpnt-%data% fixpnt-%offset%)
79           (ipvtg f2cl-lib:integer4 ipvtg-%data% ipvtg-%offset%)
80           (integs f2cl-lib:integer4 integs-%data% integs-%offset%)
81           (ipvtw f2cl-lib:integer4 ipvtw-%data% ipvtw-%offset%))
82        (prog ((ifin 0) (lj 0) (j 0) (fact 0.0) (factor 0.0) (arg 0.0)
83               (anfix 0.0) (anorm 0.0) (ipred 0) (rlxold 0.0) (andif 0.0)
84               (anscl 0.0) (np1 0) (iz 0) (inz 0) (it 0) (ifrz 0) (rnold 0.0)
85               (ifreez 0) (relax 0.0) (rnorm 0.0) (msing 0) (noconv 0) (icor 0)
86               (iconv 0) (imesh 0) (i 0) (check 0.0) (lmtfrz 0) (rstart 0.0)
87               (relmin 0.0) (dummy (make-array 1 :element-type 'double-float)))
88          (declare (type (array double-float (1)) dummy)
89                   (type double-float relmin rstart check rnorm relax rnold
90                                      anscl andif rlxold anorm anfix arg factor
91                                      fact)
92                   (type (f2cl-lib:integer4) lmtfrz i imesh iconv icor noconv
93                                             msing ifreez ifrz it inz iz np1
94                                             ipred j lj ifin))
95          (setf relmin 0.001)
96          (setf rstart 0.01)
97          (setf lmtfrz 4)
98          (setf check 0.0)
99          (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
100                        ((> i ntol) nil)
101            (tagbody
102             label10
103              (setf check
104                      (f2cl-lib:dmax1 (f2cl-lib:fref tolin (i) ((1 40)))
105                                      check))))
106          (setf imesh 1)
107          (setf iconv 0)
108          (if (= nonlin 0) (setf iconv 1))
109          (setf icor 0)
110          (setf noconv 0)
111          (setf msing 0)
112         label20
113          (setf iter 0)
114          (if (> nonlin 0) (go label50))
115          (multiple-value-bind
116                (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
117                 var-10 var-11 var-12 var-13 var-14 var-15 var-16 var-17 var-18
118                 var-19 var-20 var-21)
119              (lsyslv msing xi xiold dummy dummy z dmz g w v rhs dummy integs
120               ipvtg ipvtw rnorm 0 fsub dfsub gsub dgsub guess)
121            (declare (ignore var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8
122                             var-9 var-10 var-11 var-12 var-13 var-14 var-16
123                             var-17 var-18 var-19 var-20 var-21))
124            (setf msing var-0)
125            (setf rnorm var-15))
126          (if (= msing 0) (go label400))
127         label30
128          (if (< msing 0) (go label40))
129          (if (< iprint 1)
130              (f2cl-lib:fformat iout
131                                ("~%" "~%"
132                                 " A LOCAL ELIMINATION MATRIX IS SINGULAR "
133                                 "~%")))
134          (go label460)
135         label40
136          (if (< iprint 1)
137              (f2cl-lib:fformat iout
138                                ("~%" "~%"
139                                 " THE GLOBAL BVP-MATRIX IS SINGULAR " "~%")))
140          (setf iflag 0)
141          (go end_label)
142         label50
143          (setf relax 1.0)
144          (if (or (= icare 1) (= icare -1)) (setf relax rstart))
145          (if (= iconv 0) (go label160))
146          (setf ifreez 0)
147          (multiple-value-bind
148                (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
149                 var-10 var-11 var-12 var-13 var-14 var-15 var-16 var-17 var-18
150                 var-19 var-20 var-21)
151              (lsyslv msing xi xiold z dmz delz deldmz g w v rhs dqdmz integs
152               ipvtg ipvtw rnold 1 fsub dfsub gsub dgsub guess)
153            (declare (ignore var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8
154                             var-9 var-10 var-11 var-12 var-13 var-14 var-16
155                             var-17 var-18 var-19 var-20 var-21))
156            (setf msing var-0)
157            (setf rnold var-15))
158          (if (< iprint 0)
159              (f2cl-lib:fformat iout
160                                ("~%" " FIXED JACOBIAN ITERATIONS," "~%")))
161          (if (< iprint 0)
162              (f2cl-lib:fformat iout
163                                (" ITERATION = " 1 (("~3D")) "  NORM (RHS) = "
164                                 1 (("~10,2,2,0,'*,,'DE")) "~%")
165                                iter
166                                rnold))
167          (go label70)
168         label60
169          (if (< iprint 0)
170              (f2cl-lib:fformat iout
171                                (" ITERATION = " 1 (("~3D")) "  NORM (RHS) = "
172                                 1 (("~10,2,2,0,'*,,'DE")) "~%")
173                                iter
174                                rnorm))
175          (setf rnold rnorm)
176          (multiple-value-bind
177                (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
178                 var-10 var-11 var-12 var-13 var-14 var-15 var-16 var-17 var-18
179                 var-19 var-20 var-21)
180              (lsyslv msing xi xiold z dmz delz deldmz g w v rhs dummy integs
181               ipvtg ipvtw rnorm (f2cl-lib:int-add 3 ifreez) fsub dfsub gsub
182               dgsub guess)
183            (declare (ignore var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8
184                             var-9 var-10 var-11 var-12 var-13 var-14 var-16
185                             var-17 var-18 var-19 var-20 var-21))
186            (setf msing var-0)
187            (setf rnorm var-15))
188         label70
189          (if (/= msing 0) (go label30))
190          (if (= ifreez 1) (go label80))
191          (setf iter (f2cl-lib:int-add iter 1))
192          (setf ifrz 0)
193         label80
194          (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
195                        ((> i nz) nil)
196            (tagbody
197              (setf (f2cl-lib:fref z-%data% (i) ((1 1)) z-%offset%)
198                      (+ (f2cl-lib:fref z-%data% (i) ((1 1)) z-%offset%)
199                         (f2cl-lib:fref delz-%data%
200                                        (i)
201                                        ((1 1))
202                                        delz-%offset%)))
203             label90))
204          (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
205                        ((> i ndmz) nil)
206            (tagbody
207              (setf (f2cl-lib:fref dmz-%data% (i) ((1 1)) dmz-%offset%)
208                      (+ (f2cl-lib:fref dmz-%data% (i) ((1 1)) dmz-%offset%)
209                         (f2cl-lib:fref deldmz-%data%
210                                        (i)
211                                        ((1 1))
212                                        deldmz-%offset%)))
213             label100))
214          (multiple-value-bind
215                (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
216                 var-10 var-11 var-12 var-13 var-14 var-15 var-16 var-17 var-18
217                 var-19 var-20 var-21)
218              (lsyslv msing xi xiold z dmz delz deldmz g w v rhs dummy integs
219               ipvtg ipvtw rnorm 2 fsub dfsub gsub dgsub guess)
220            (declare (ignore var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8
221                             var-9 var-10 var-11 var-12 var-13 var-14 var-16
222                             var-17 var-18 var-19 var-20 var-21))
223            (setf msing var-0)
224            (setf rnorm var-15))
225          (if (< rnorm precis) (go label390))
226          (if (> rnorm rnold) (go label130))
227          (if (= ifreez 1) (go label110))
228          (setf ifreez 1)
229          (go label60)
230         label110
231          (setf ifrz (f2cl-lib:int-add ifrz 1))
232          (if (>= ifrz lmtfrz) (setf ifreez 0))
233          (if (< rnold (* 4.0 rnorm)) (setf ifreez 0))
234          (f2cl-lib:fdo (it 1 (f2cl-lib:int-add it 1))
235                        ((> it ntol) nil)
236            (tagbody
237              (setf inz (f2cl-lib:fref ltol (it) ((1 40))))
238              (f2cl-lib:fdo (iz inz (f2cl-lib:int-add iz mstar))
239                            ((> iz nz) nil)
240                (tagbody
241                  (if
242                   (>
243                    (f2cl-lib:dabs
244                     (f2cl-lib:fref delz-%data% (iz) ((1 1)) delz-%offset%))
245                    (* (f2cl-lib:fref tolin (it) ((1 40)))
246                       (+
247                        (f2cl-lib:dabs
248                         (f2cl-lib:fref z-%data% (iz) ((1 1)) z-%offset%))
249                        1.0)))
250                   (go label60))
251                 label120))))
252         label120
253          (if (< iprint 1)
254              (f2cl-lib:fformat iout
255                                ("~%" " CONVERGENCE AFTER" 1 (("~3D"))
256                                 " ITERATIONS" "~%" "~%")
257                                iter))
258          (go label400)
259         label130
260          (if (< iprint 0)
261              (f2cl-lib:fformat iout
262                                (" ITERATION = " 1 (("~3D")) "  NORM (RHS) = "
263                                 1 (("~10,2,2,0,'*,,'DE")) "~%")
264                                iter
265                                rnorm))
266          (if (< iprint 0)
267              (f2cl-lib:fformat iout
268                                ("~%" " SWITCH TO DAMPED NEWTON ITERATION,"
269                                 "~%")))
270          (setf iconv 0)
271          (setf relax rstart)
272          (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
273                        ((> i nz) nil)
274            (tagbody
275              (setf (f2cl-lib:fref z-%data% (i) ((1 1)) z-%offset%)
276                      (- (f2cl-lib:fref z-%data% (i) ((1 1)) z-%offset%)
277                         (f2cl-lib:fref delz-%data%
278                                        (i)
279                                        ((1 1))
280                                        delz-%offset%)))
281             label140))
282          (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
283                        ((> i ndmz) nil)
284            (tagbody
285              (setf (f2cl-lib:fref dmz-%data% (i) ((1 1)) dmz-%offset%)
286                      (- (f2cl-lib:fref dmz-%data% (i) ((1 1)) dmz-%offset%)
287                         (f2cl-lib:fref deldmz-%data%
288                                        (i)
289                                        ((1 1))
290                                        deldmz-%offset%)))
291             label150))
292          (setf np1 (f2cl-lib:int-add n 1))
293          (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
294                        ((> i np1) nil)
295            (tagbody
296             label155
297              (setf (f2cl-lib:fref xiold-%data% (i) ((1 1)) xiold-%offset%)
298                      (f2cl-lib:fref xi-%data% (i) ((1 1)) xi-%offset%))))
299          (setf nold n)
300          (setf iter 0)
301         label160
302          (if (< iprint 0)
303              (f2cl-lib:fformat iout
304                                ("~%" " FULL DAMPED NEWTON ITERATION," "~%")))
305          (multiple-value-bind
306                (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
307                 var-10 var-11 var-12 var-13 var-14 var-15 var-16 var-17 var-18
308                 var-19 var-20 var-21)
309              (lsyslv msing xi xiold z dmz delz deldmz g w v rhs dqdmz integs
310               ipvtg ipvtw rnold 1 fsub dfsub gsub dgsub guess)
311            (declare (ignore var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8
312                             var-9 var-10 var-11 var-12 var-13 var-14 var-16
313                             var-17 var-18 var-19 var-20 var-21))
314            (setf msing var-0)
315            (setf rnold var-15))
316          (if (/= msing 0) (go label30))
317          (if (= iguess 1) (setf iguess 0))
318          (skale n mstar kd z xi scale dscale)
319          (go label220)
320         label170
321          (setf rnold rnorm)
322          (if (>= iter limit) (go label430))
323          (skale n mstar kd z xi scale dscale)
324          (setf anscl 0.0)
325          (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
326                        ((> i nz) nil)
327            (tagbody
328              (setf anscl
329                      (+ anscl
330                         (expt
331                          (*
332                           (f2cl-lib:fref delz-%data%
333                                          (i)
334                                          ((1 1))
335                                          delz-%offset%)
336                           (f2cl-lib:fref scale-%data%
337                                          (i)
338                                          ((1 1))
339                                          scale-%offset%))
340                          2)))
341             label180))
342          (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
343                        ((> i ndmz) nil)
344            (tagbody
345              (setf anscl
346                      (+ anscl
347                         (expt
348                          (*
349                           (f2cl-lib:fref deldmz-%data%
350                                          (i)
351                                          ((1 1))
352                                          deldmz-%offset%)
353                           (f2cl-lib:fref dscale-%data%
354                                          (i)
355                                          ((1 1))
356                                          dscale-%offset%))
357                          2)))
358             label190))
359          (setf anscl
360                  (f2cl-lib:dsqrt
361                   (/ anscl (f2cl-lib:dfloat (f2cl-lib:int-add nz ndmz)))))
362          (multiple-value-bind
363                (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
364                 var-10 var-11 var-12 var-13 var-14 var-15 var-16 var-17 var-18
365                 var-19 var-20 var-21)
366              (lsyslv msing xi xiold z dmz delz deldmz g w v rhs dummy integs
367               ipvtg ipvtw rnorm 3 fsub dfsub gsub dgsub guess)
368            (declare (ignore var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8
369                             var-9 var-10 var-11 var-12 var-13 var-14 var-16
370                             var-17 var-18 var-19 var-20 var-21))
371            (setf msing var-0)
372            (setf rnorm var-15))
373          (if (/= msing 0) (go label30))
374          (setf andif 0.0)
375          (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
376                        ((> i nz) nil)
377            (tagbody
378              (setf andif
379                      (+ andif
380                         (expt
381                          (*
382                           (-
383                            (f2cl-lib:fref dqz-%data% (i) ((1 1)) dqz-%offset%)
384                            (f2cl-lib:fref delz-%data%
385                                           (i)
386                                           ((1 1))
387                                           delz-%offset%))
388                           (f2cl-lib:fref scale-%data%
389                                          (i)
390                                          ((1 1))
391                                          scale-%offset%))
392                          2)))
393             label200))
394          (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
395                        ((> i ndmz) nil)
396            (tagbody
397              (setf andif
398                      (+ andif
399                         (expt
400                          (*
401                           (-
402                            (f2cl-lib:fref dqdmz-%data%
403                                           (i)
404                                           ((1 1))
405                                           dqdmz-%offset%)
406                            (f2cl-lib:fref deldmz-%data%
407                                           (i)
408                                           ((1 1))
409                                           deldmz-%offset%))
410                           (f2cl-lib:fref dscale-%data%
411                                          (i)
412                                          ((1 1))
413                                          dscale-%offset%))
414                          2)))
415             label210))
416          (setf andif
417                  (f2cl-lib:dsqrt
418                   (+ (/ andif (f2cl-lib:dfloat (f2cl-lib:int-add nz ndmz)))
419                      precis)))
420          (setf relax (/ (* relax anscl) andif))
421          (if (> relax 1.0) (setf relax 1.0))
422         label220
423          (setf rlxold relax)
424          (setf ipred 1)
425          (setf iter (f2cl-lib:int-add iter 1))
426          (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
427                        ((> i nz) nil)
428            (tagbody
429              (setf (f2cl-lib:fref z-%data% (i) ((1 1)) z-%offset%)
430                      (+ (f2cl-lib:fref z-%data% (i) ((1 1)) z-%offset%)
431                         (* relax
432                            (f2cl-lib:fref delz-%data%
433                                           (i)
434                                           ((1 1))
435                                           delz-%offset%))))
436             label230))
437          (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
438                        ((> i ndmz) nil)
439            (tagbody
440              (setf (f2cl-lib:fref dmz-%data% (i) ((1 1)) dmz-%offset%)
441                      (+ (f2cl-lib:fref dmz-%data% (i) ((1 1)) dmz-%offset%)
442                         (* relax
443                            (f2cl-lib:fref deldmz-%data%
444                                           (i)
445                                           ((1 1))
446                                           deldmz-%offset%))))
447             label240))
448         label250
449          (multiple-value-bind
450                (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
451                 var-10 var-11 var-12 var-13 var-14 var-15 var-16 var-17 var-18
452                 var-19 var-20 var-21)
453              (lsyslv msing xi xiold z dmz dqz dqdmz g w v rhs dummy integs
454               ipvtg ipvtw rnorm 2 fsub dfsub gsub dgsub guess)
455            (declare (ignore var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8
456                             var-9 var-10 var-11 var-12 var-13 var-14 var-16
457                             var-17 var-18 var-19 var-20 var-21))
458            (setf msing var-0)
459            (setf rnorm var-15))
460          (multiple-value-bind
461                (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
462                 var-10 var-11 var-12 var-13 var-14 var-15 var-16 var-17 var-18
463                 var-19 var-20 var-21)
464              (lsyslv msing xi xiold z dmz dqz dqdmz g w v rhs dummy integs
465               ipvtg ipvtw rnorm 4 fsub dfsub gsub dgsub guess)
466            (declare (ignore var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8
467                             var-9 var-10 var-11 var-12 var-13 var-14 var-16
468                             var-17 var-18 var-19 var-20 var-21))
469            (setf msing var-0)
470            (setf rnorm var-15))
471          (setf anorm 0.0)
472          (setf anfix 0.0)
473          (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
474                        ((> i nz) nil)
475            (tagbody
476              (setf anorm
477                      (+ anorm
478                         (expt
479                          (*
480                           (f2cl-lib:fref delz-%data%
481                                          (i)
482                                          ((1 1))
483                                          delz-%offset%)
484                           (f2cl-lib:fref scale-%data%
485                                          (i)
486                                          ((1 1))
487                                          scale-%offset%))
488                          2)))
489              (setf anfix
490                      (+ anfix
491                         (expt
492                          (*
493                           (f2cl-lib:fref dqz-%data% (i) ((1 1)) dqz-%offset%)
494                           (f2cl-lib:fref scale-%data%
495                                          (i)
496                                          ((1 1))
497                                          scale-%offset%))
498                          2)))
499             label260))
500          (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
501                        ((> i ndmz) nil)
502            (tagbody
503              (setf anorm
504                      (+ anorm
505                         (expt
506                          (*
507                           (f2cl-lib:fref deldmz-%data%
508                                          (i)
509                                          ((1 1))
510                                          deldmz-%offset%)
511                           (f2cl-lib:fref dscale-%data%
512                                          (i)
513                                          ((1 1))
514                                          dscale-%offset%))
515                          2)))
516              (setf anfix
517                      (+ anfix
518                         (expt
519                          (*
520                           (f2cl-lib:fref dqdmz-%data%
521                                          (i)
522                                          ((1 1))
523                                          dqdmz-%offset%)
524                           (f2cl-lib:fref dscale-%data%
525                                          (i)
526                                          ((1 1))
527                                          dscale-%offset%))
528                          2)))
529             label270))
530          (setf anorm
531                  (f2cl-lib:dsqrt
532                   (/ anorm (f2cl-lib:dfloat (f2cl-lib:int-add nz ndmz)))))
533          (setf anfix
534                  (f2cl-lib:dsqrt
535                   (/ anfix (f2cl-lib:dfloat (f2cl-lib:int-add nz ndmz)))))
536          (if (= icor 1) (go label280))
537          (if (< iprint 0)
538              (f2cl-lib:fformat iout
539                                (" ITERATION = " 1 (("~3D"))
540                                 "  RELAXATION FACTOR = " 1
541                                 (("~10,2,2,0,'*,,'DE")) "~%"
542                                 " NORM OF SCALED RHS CHANGES FROM " 1
543                                 (("~10,2,2,0,'*,,'DE")) " TO" 1
544                                 (("~10,2,2,0,'*,,'DE")) "~%"
545                                 " NORM   OF   RHS  CHANGES  FROM  " 1
546                                 (("~10,2,2,0,'*,,'DE")) " TO" 1
547                                 (("~10,2,2,0,'*,,'DE")) 1
548                                 (("~10,2,2,0,'*,,'DE")) "~%")
549                                iter
550                                relax
551                                anorm
552                                anfix
553                                rnold
554                                rnorm))
555          (go label290)
556         label280
557          (if (< iprint 0)
558              (f2cl-lib:fformat iout
559                                (" RELAXATION FACTOR CORRECTED TO RELAX = " 1
560                                 (("~10,2,2,0,'*,,'DE")) "~%"
561                                 " NORM OF SCALED RHS CHANGES FROM " 1
562                                 (("~10,2,2,0,'*,,'DE")) " TO" 1
563                                 (("~10,2,2,0,'*,,'DE")) "~%"
564                                 " NORM   OF   RHS  CHANGES  FROM  " 1
565                                 (("~10,2,2,0,'*,,'DE")) " TO" 1
566                                 (("~10,2,2,0,'*,,'DE")) 1
567                                 (("~10,2,2,0,'*,,'DE")) "~%")
568                                relax
569                                anorm
570                                anfix
571                                rnold
572                                rnorm))
573         label290
574          (setf icor 0)
575          (if (or (< anfix precis) (< rnorm precis)) (go label390))
576          (if (> anfix anorm) (go label300))
577          (if (<= anfix check) (go label350))
578          (if (/= ipred 1) (go label170))
579         label300
580          (if (>= iter limit) (go label430))
581          (setf ipred 0)
582          (setf arg (+ (/ (- (/ anfix anorm) 1.0) relax) 1.0))
583          (if (< arg 0.0) (go label170))
584          (if (<= arg (+ (* 0.25 relax) (* 0.125 (expt relax 2))))
585              (go label310))
586          (setf factor (- (f2cl-lib:dsqrt (+ 1.0 (* 8.0 arg))) 1.0))
587          (if (< (f2cl-lib:dabs (- factor 1.0)) (* 0.1 factor)) (go label170))
588          (if (< factor 0.5) (setf factor 0.5))
589          (setf relax (/ relax factor))
590          (go label320)
591         label310
592          (if (>= relax 0.9) (go label170))
593          (setf relax 1.0)
594         label320
595          (setf icor 1)
596          (if (< relax relmin) (go label440))
597          (setf fact (- relax rlxold))
598          (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
599                        ((> i nz) nil)
600            (tagbody
601              (setf (f2cl-lib:fref z-%data% (i) ((1 1)) z-%offset%)
602                      (+ (f2cl-lib:fref z-%data% (i) ((1 1)) z-%offset%)
603                         (* fact
604                            (f2cl-lib:fref delz-%data%
605                                           (i)
606                                           ((1 1))
607                                           delz-%offset%))))
608             label330))
609          (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
610                        ((> i ndmz) nil)
611            (tagbody
612              (setf (f2cl-lib:fref dmz-%data% (i) ((1 1)) dmz-%offset%)
613                      (+ (f2cl-lib:fref dmz-%data% (i) ((1 1)) dmz-%offset%)
614                         (* fact
615                            (f2cl-lib:fref deldmz-%data%
616                                           (i)
617                                           ((1 1))
618                                           deldmz-%offset%))))
619             label340))
620          (setf rlxold relax)
621          (go label250)
622         label350
623          (f2cl-lib:fdo (it 1 (f2cl-lib:int-add it 1))
624                        ((> it ntol) nil)
625            (tagbody
626              (setf inz (f2cl-lib:fref ltol (it) ((1 40))))
627              (f2cl-lib:fdo (iz inz (f2cl-lib:int-add iz mstar))
628                            ((> iz nz) nil)
629                (tagbody
630                  (if
631                   (>
632                    (f2cl-lib:dabs
633                     (f2cl-lib:fref dqz-%data% (iz) ((1 1)) dqz-%offset%))
634                    (* (f2cl-lib:fref tolin (it) ((1 40)))
635                       (+
636                        (f2cl-lib:dabs
637                         (f2cl-lib:fref z-%data% (iz) ((1 1)) z-%offset%))
638                        1.0)))
639                   (go label170))
640                 label360))))
641         label360
642          (if (< iprint 1)
643              (f2cl-lib:fformat iout
644                                ("~%" " CONVERGENCE AFTER" 1 (("~3D"))
645                                 " ITERATIONS" "~%" "~%")
646                                iter))
647          (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
648                        ((> i nz) nil)
649            (tagbody
650              (setf (f2cl-lib:fref z-%data% (i) ((1 1)) z-%offset%)
651                      (+ (f2cl-lib:fref z-%data% (i) ((1 1)) z-%offset%)
652                         (f2cl-lib:fref dqz-%data% (i) ((1 1)) dqz-%offset%)))
653             label370))
654          (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
655                        ((> i ndmz) nil)
656            (tagbody
657              (setf (f2cl-lib:fref dmz-%data% (i) ((1 1)) dmz-%offset%)
658                      (+ (f2cl-lib:fref dmz-%data% (i) ((1 1)) dmz-%offset%)
659                         (f2cl-lib:fref dqdmz-%data%
660                                        (i)
661                                        ((1 1))
662                                        dqdmz-%offset%)))
663             label380))
664         label390
665          (if (and (or (< anfix precis) (< rnorm precis)) (< iprint 1))
666              (f2cl-lib:fformat iout
667                                ("~%" " CONVERGENCE AFTER" 1 (("~3D"))
668                                 " ITERATIONS" "~%" "~%")
669                                iter))
670          (setf iconv 1)
671          (if (= icare -1) (setf icare 0))
672         label400
673          (if (>= iprint 0) (go label420))
674          (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
675                        ((> j mstar) nil)
676            (tagbody
677              (f2cl-lib:fformat iout
678                                (" MESH VALUES FOR Z(" 1 (("~2D")) ")," "~%")
679                                j)
680             label410
681              (f2cl-lib:fformat iout
682                                (" " 8 (("~15,7,2,0,'*,,'DE")) "~%")
683                                (do ((lj j (f2cl-lib:int-add lj mstar))
684                                     (%ret nil))
685                                    ((> lj nz) (nreverse %ret))
686                                  (declare (type f2cl-lib:integer4 lj))
687                                  (push
688                                   (f2cl-lib:fref z-%data%
689                                                  (lj)
690                                                  ((1 1))
691                                                  z-%offset%)
692                                   %ret)))))
693         label420
694          (setf ifin 1)
695          (if (= imesh 2)
696              (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
697                  (errchk xi z dmz valstr ifin)
698                (declare (ignore var-0 var-1 var-2 var-3))
699                (setf ifin var-4)))
700          (if (or (= imesh 1) (and (= ifin 0) (/= icare 2))) (go label460))
701          (setf iflag 1)
702          (go end_label)
703         label430
704          (if (< iprint 1)
705              (f2cl-lib:fformat iout
706                                ("~%" " NO CONVERGENCE AFTER " 1 (("~3D"))
707                                 " ITERATIONS" "~%" "~%")
708                                iter))
709          (go label450)
710         label440
711          (if (< iprint 1)
712              (f2cl-lib:fformat iout
713                                ("~%" " NO CONVERGENCE.  RELAXATION FACTOR =" 1
714                                 (("~10,3,2,0,'*,,'DE"))
715                                 " IS TOO SMALL (LESS THAN" 1
716                                 (("~10,3,2,0,'*,,'DE")) ")" "~%" "~%")
717                                relax
718                                relmin))
719         label450
720          (setf iflag -2)
721          (setf noconv (f2cl-lib:int-add noconv 1))
722          (if (and (= icare 2) (> noconv 1)) (go end_label))
723          (if (= icare 0) (setf icare -1))
724         label460
725          (setf np1 (f2cl-lib:int-add n 1))
726          (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
727                        ((> i np1) nil)
728            (tagbody
729             label470
730              (setf (f2cl-lib:fref xiold-%data% (i) ((1 1)) xiold-%offset%)
731                      (f2cl-lib:fref xi-%data% (i) ((1 1)) xi-%offset%))))
732          (setf nold n)
733          (setf imesh 1)
734          (if (or (= iconv 0) (>= mshnum mshlmt) (>= mshalt mshlmt))
735              (setf imesh 2))
736          (if (and (>= mshalt mshlmt) (< mshnum mshlmt)) (setf mshalt 1))
737          (multiple-value-bind
738                (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9)
739              (newmsh imesh xi xiold z dmz valstr slope accum nfxpnt fixpnt)
740            (declare (ignore var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8
741                             var-9))
742            (setf imesh var-0))
743          (if (<= n nmax) (go label480))
744          (setf n (the f2cl-lib:integer4 (truncate n 2)))
745          (setf iflag -1)
746          (if (and (= iconv 0) (< iprint 1))
747              (f2cl-lib:fformat iout ("  (NO CONVERGENCE)" "~%")))
748          (if (and (= iconv 1) (< iprint 1))
749              (f2cl-lib:fformat iout
750                                ("  (PROBABLY TOLERANCES TOO STRINGENT, OR NMAX TOO "
751                                 "SMALL)" "~%")))
752          (go end_label)
753         label480
754          (if (= iconv 0) (setf imesh 1))
755          (if (= icare 1) (setf iconv 0))
756          (go label20)
757         end_label
758          (return
759           (values nil
760                   nil
761                   nil
762                   nil
763                   nil
764                   nil
765                   nil
766                   nil
767                   nil
768                   nil
769                   nil
770                   nil
771                   nil
772                   nil
773                   nil
774                   nil
775                   nil
776                   nil
777                   nil
778                   nil
779                   nil
780                   nil
781                   iflag
782                   nil
783                   nil
784                   nil
785                   nil
786                   nil)))))))
787
788(in-package #-gcl #:cl-user #+gcl "CL-USER")
789#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
790(eval-when (:load-toplevel :compile-toplevel :execute)
791  (setf (gethash 'fortran-to-lisp::contrl
792                 fortran-to-lisp::*f2cl-function-info*)
793          (fortran-to-lisp::make-f2cl-finfo
794           :arg-types '((array double-float (1)) (array double-float (1))
795                        (array double-float (1)) (array double-float (1))
796                        (array double-float (1)) (array double-float (1))
797                        (array double-float (1)) (array double-float (1))
798                        (array double-float (1)) (array double-float (1))
799                        (array double-float (1)) (array double-float (1))
800                        (array double-float (1)) (array double-float (1))
801                        (array double-float (1)) (array double-float (1))
802                        (array double-float (1))
803                        (array fortran-to-lisp::integer4 (1))
804                        (array fortran-to-lisp::integer4 (1))
805                        (array fortran-to-lisp::integer4 (1))
806                        (fortran-to-lisp::integer4) (array double-float (1))
807                        (fortran-to-lisp::integer4) t t t t t)
808           :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil
809                            nil nil nil nil nil nil nil nil nil
810                            fortran-to-lisp::iflag nil nil nil nil nil)
811           :calls '(fortran-to-lisp::newmsh fortran-to-lisp::errchk
812                    fortran-to-lisp::skale fortran-to-lisp::lsyslv))))
813
814