OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
imp_bfgs.F
Go to the documentation of this file.
1Copyright> OpenRadioss
2Copyright> Copyright (C) 1986-2025 Altair Engineering Inc.
3Copyright>
4Copyright> This program is free software: you can redistribute it and/or modify
5Copyright> it under the terms of the GNU Affero General Public License as published by
6Copyright> the Free Software Foundation, either version 3 of the License, or
7Copyright> (at your option) any later version.
8Copyright>
9Copyright> This program is distributed in the hope that it will be useful,
10Copyright> but WITHOUT ANY WARRANTY; without even the implied warranty of
11Copyright> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12Copyright> GNU Affero General Public License for more details.
13Copyright>
14Copyright> You should have received a copy of the GNU Affero General Public License
15Copyright> along with this program. If not, see <https://www.gnu.org/licenses/>.
16Copyright>
17Copyright>
18Copyright> Commercial Alternative: Altair Radioss Software
19Copyright>
20Copyright> As an alternative to this open-source version, Altair also offers Altair Radioss
21Copyright> software under a commercial license. Contact Altair to discuss further if the
22Copyright> commercial version may interest you: https://www.altair.com/radioss/.
23!||====================================================================
24!|| bfgs_ini ../engine/source/implicit/imp_bfgs.F
25!||--- called by ------------------------------------------------------
26!|| imp_solv ../engine/source/implicit/imp_solv.F
27!||--- uses -----------------------------------------------------
28!|| imp_bfgs ../engine/share/modules/impbufdef_mod.F
29!||====================================================================
30 SUBROUTINE bfgs_ini(NDDL,MAX_BFGS)
31C-----------------------------------------------
32C M o d u l e s
33C-----------------------------------------------
34 USE imp_bfgs
35C-----------------------------------------------
36C I m p l i c i t T y p e s
37C-----------------------------------------------
38#include "implicit_f.inc"
39C-----------------------------------------------
40C C o m m o n B l o c k s
41C-----------------------------------------------
42#include "impl1_c.inc"
43C-----------------------------------------------
44C D u m m y A r g u m e n t s
45C-----------------------------------------------
46C REAL
47 INTEGER NDDL,MAX_BFGS
48C-----------------------------------------------
49C L o c a l V a r i a b l e s
50C-----------------------------------------------
51 INTEGER IER1,IER2,IER3,LV
52C------------------------------------------
53C
54 IF (insolv==5) THEN
55 IF(ALLOCATED(bfgs_v)) DEALLOCATE(bfgs_v)
56 ALLOCATE(bfgs_v(nddl,1),stat=ier2)
57 ELSE
58 IF(l_bfgs==0) THEN
59 lv = max_bfgs
60 ELSE
61 lv = l_bfgs
62 ENDIF
63C
64 IF(ALLOCATED(bfgs_v)) DEALLOCATE(bfgs_v)
65 ALLOCATE(bfgs_v(nddl,lv),stat=ier2)
66C
67 IF(ALLOCATED(bfgs_w)) DEALLOCATE(bfgs_w)
68 ALLOCATE(bfgs_w(nddl,lv),stat=ier3)
69 ENDIF
70C
71 RETURN
72 END
73!||====================================================================
74!|| bfgs_0 ../engine/source/implicit/imp_bfgs.F
75!||--- called by ------------------------------------------------------
76!|| nl_solv ../engine/source/implicit/nl_solv.F
77!||--- uses -----------------------------------------------------
78!|| imp_bfgs ../engine/share/modules/impbufdef_mod.F
79!||====================================================================
80 SUBROUTINE bfgs_0
81C-----------------------------------------------
82C M o d u l e s
83C-----------------------------------------------
84 USE imp_bfgs
85C-----------------------------------------------
86C I m p l i c i t T y p e s
87C-----------------------------------------------
88#include "implicit_f.inc"
89C-----------------------------------------------
90C L o c a l V a r i a b l e s
91C-----------------------------------------------
92 INTEGER I
93C------------------------------------------
94 n_bfgs = 0
95 s_lin = one
96C
97 iactb = 0
98C
99 RETURN
100 END
101!||====================================================================
102!|| bfgs_ls ../engine/source/implicit/imp_bfgs.F
103!||--- called by ------------------------------------------------------
104!|| nl_solv ../engine/source/implicit/nl_solv.F
105!||--- uses -----------------------------------------------------
106!|| imp_bfgs ../engine/share/modules/impbufdef_mod.F
107!||====================================================================
108 SUBROUTINE bfgs_ls(LS)
109C-----------------------------------------------
110C M o d u l e s
111C-----------------------------------------------
112 USE imp_bfgs
113C-----------------------------------------------
114C I m p l i c i t T y p e s
115C-----------------------------------------------
116#include "implicit_f.inc"
117C-----------------------------------------------
118C D u m m y A r g u m e n t s
119C-----------------------------------------------
120 my_real
121 . ls
122C-----------------------------------------------
123C L o c a l V a r i a b l e s
124C-----------------------------------------------
125 INTEGER I
126C------------------------------------------
127 s_lin = ls
128C
129 RETURN
130 END
131!||====================================================================
132!|| bfgs_1 ../engine/source/implicit/imp_bfgs.F
133!||--- calls -----------------------------------------------------
134!|| bfgs_rhd ../engine/source/implicit/imp_bfgs.F
135!|| produt_w ../engine/source/implicit/produt_v.F
136!||--- uses -----------------------------------------------------
137!|| imp_bfgs ../engine/share/modules/impbufdef_mod.F
138!||====================================================================
139 SUBROUTINE bfgs_1(NDDL,W_DDL,F,A2,IT)
140C-----------------------------------------------
141C M o d u l e s
142C-----------------------------------------------
143 USE imp_bfgs
144C-----------------------------------------------
145C I m p l i c i t T y p e s
146C-----------------------------------------------
147#include "implicit_f.inc"
148C-----------------------------------------------
149C D u m m y A r g u m e n t s
150C-----------------------------------------------
151 INTEGER NDDL,W_DDL(*),IT
152 my_real
153 . f(*) ,a2
154C-----------------------------------------------
155C L o c a l V a r i a b l e s
156C-----------------------------------------------
157 INTEGER I ,N
158 my_real
159 . a1 ,b1
160C------------------------------------------
161 IF (it==0.OR.(iactb==0.AND.it<2)) RETURN
162 n = n_bfgs + 1
163C--------V->dr----------------------------------
164 a2=zero
165 DO i=1,nddl
166 bfgs_v(i,n) = f(i) - bfgs_v(i,n)
167 ENDDO
168 CALL produt_w(nddl,bfgs_w(1,n),bfgs_v(1,n),w_ddl,a1)
169 IF (abs(a1)>em10) THEN
170 n_bfgs = n
171 CALL produt_w(nddl,bfgs_w(1,n),f,w_ddl,a2)
172 a2 = a2*s_lin
173C--------W->b1*du----------------------------------
174 b1 = one/a1
175 DO i=1,nddl
176 bfgs_w(i,n) = b1*bfgs_w(i,n)
177 ENDDO
178 ELSE
179 ENDIF
180 DO i=n_bfgs,1,-1
181 CALL bfgs_rhd(nddl,w_ddl,bfgs_w(1,i),bfgs_v(1,i),f)
182 ENDDO
183C
184 RETURN
185 END
186!||====================================================================
187!|| bfgs_rhd ../engine/source/implicit/imp_bfgs.F
188!||--- called by ------------------------------------------------------
189!|| bfgs_1 ../engine/source/implicit/imp_bfgs.F
190!|| bfgs_1p ../engine/source/implicit/imp_bfgs.F
191!|| bfgs_2 ../engine/source/implicit/imp_bfgs.F
192!|| bfgs_2p ../engine/source/implicit/imp_bfgs.F
193!||--- calls -----------------------------------------------------
194!|| produt_w ../engine/source/implicit/produt_v.F
195!||====================================================================
196 SUBROUTINE bfgs_rhd(NDDL,W_DDL,BW,BV,B)
197C-----------------------------------------------
198C I m p l i c i t T y p e s
199C-----------------------------------------------
200#include "implicit_f.inc"
201C-----------------------------------------------
202C D u m m y A r g u m e n t s
203C-----------------------------------------------
204C REAL
205 INTEGER NDDL,W_DDL(*)
206 my_real
207 . bw(*),bv(*),b(*)
208C-----------------------------------------------
209C L o c a l V a r i a b l e s
210C-----------------------------------------------
211 INTEGER I
212 my_real
213 . a1
214C------------------------------------------
215 CALL produt_w(nddl,bw,b,w_ddl,a1)
216C
217 DO i=1,nddl
218 b(i) = b(i) - a1*bv(i)
219 ENDDO
220C
221 RETURN
222 END
223!||====================================================================
224!|| bfgs_2 ../engine/source/implicit/imp_bfgs.F
225!||--- calls -----------------------------------------------------
226!|| bfgs_rhd ../engine/source/implicit/imp_bfgs.F
227!||--- uses -----------------------------------------------------
228!|| imp_bfgs ../engine/share/modules/impbufdef_mod.F
229!||====================================================================
230 SUBROUTINE bfgs_2(NDDL,W_DDL,U,F,A2,IT,MAX_BFGS)
231C-----------------------------------------------
232C M o d u l e s
233C-----------------------------------------------
234 USE imp_bfgs
235C-----------------------------------------------
236C I m p l i c i t T y p e s
237C-----------------------------------------------
238#include "implicit_f.inc"
239C-----------------------------------------------
240C C o m m o n B l o c k s
241C-----------------------------------------------
242#include "impl1_c.inc"
243C-----------------------------------------------
244C D u m m y A r g u m e n t s
245C-----------------------------------------------
246C REAL
247 INTEGER NDDL,W_DDL(*),IT,MAX_BFGS
248 my_real
249 . f(*) ,u(*),a2
250C-----------------------------------------------
251C L o c a l V a r i a b l e s
252C-----------------------------------------------
253 INTEGER I ,N
254C------------------------------------------
255 IF (iactb==0.AND.it==0) RETURN
256 iactb = 1
257 IF (it==0.AND.l_bfgs==0) n_bfgs = 0
258 IF(n_bfgs>0) THEN
259 DO i=1,n_bfgs
260 CALL bfgs_rhd(nddl,w_ddl,bfgs_v(1,i),bfgs_w(1,i),u)
261 ENDDO
262 IF (a2/=zero) THEN
263 DO i=1,nddl
264 u(i) = u(i) - a2*bfgs_w(i,n_bfgs)
265 ENDDO
266 ENDIF
267 ENDIF
268 IF (l_bfgs>0) THEN
269 IF (n_bfgs<l_bfgs) THEN
270 n = n_bfgs + 1
271 DO i=1,nddl
272 bfgs_w(i,n) = u(i)
273 bfgs_v(i,n) = f(i)
274 ENDDO
275 ELSEIF (n_bfgs==l_bfgs) THEN
276 n_bfgs=l_bfgs-1
277 DO n=1,n_bfgs
278 DO i=1,nddl
279 bfgs_w(i,n) = bfgs_w(i,n+1)
280 bfgs_v(i,n) = bfgs_v(i,n+1)
281 ENDDO
282 ENDDO
283 DO i=1,nddl
284 bfgs_w(i,n_bfgs+1) = u(i)
285 bfgs_v(i,n_bfgs+1) = f(i)
286 ENDDO
287 ENDIF
288 ELSE
289 IF (n_bfgs<max_bfgs) THEN
290 n = n_bfgs + 1
291 DO i=1,nddl
292 bfgs_w(i,n) = u(i)
293 bfgs_v(i,n) = f(i)
294 ENDDO
295 ENDIF
296 ENDIF
297C
298 RETURN
299 END
300!||====================================================================
301!|| bfgs_1p ../engine/source/implicit/imp_bfgs.F
302!||--- calls -----------------------------------------------------
303!|| bfgs_rhd ../engine/source/implicit/imp_bfgs.F
304!|| produt_w ../engine/source/implicit/produt_v.F
305!||--- uses -----------------------------------------------------
306!|| imp_bfgs ../engine/share/modules/impbufdef_mod.f
307!||====================================================================
308 SUBROUTINE bfgs_1p(NDDL,W_DDL,F,A2,IT)
309C-----------------------------------------------
310C M o d u l e s
311C-----------------------------------------------
312 USE imp_bfgs
313C-----------------------------------------------
314C I m p l i c i t T y p e s
315C-----------------------------------------------
316#include "implicit_f.inc"
317C-----------------------------------------------
318C D u m m y A r g u m e n t s
319C-----------------------------------------------
320C REAL
321 INTEGER NDDL,W_DDL(*),IT
322 my_real
323 . f(*) ,a2
324C-----------------------------------------------
325C L o c a l V a r i a b l e s
326C-----------------------------------------------
327 INTEGER I ,N
328 my_real
329 . a1 ,b1
330C------------------------------------------
331 IF (it==0.OR.(iactb==0.AND.it<2)) RETURN
332 n = n_bfgs + 1
333C--------V->dr----------------------------------
334 DO i=1,nddl
335 bfgs_v(i,n) = f(i) - bfgs_v(i,n)
336 ENDDO
337 CALL produt_w(nddl,bfgs_w(1,n),bfgs_v(1,n),w_ddl,a1)
338 CALL produt_w(nddl,bfgs_w(1,n),f,w_ddl,a2)
339 a1 = s_lin*a1
340 IF (abs(a2)>em10) THEN
341 b1=-a1/a2
342 IF (abs(a1)>em10.AND.b1>zero) THEN
343 n_bfgs = n
344C--------W->b1*du----------------------------------
345 b1 = sqrt(b1)
346 DO i=1,nddl
347 bfgs_w(i,n) = bfgs_w(i,n)/a1
348 bfgs_v(i,n) = bfgs_v(i,n)-b1*f(i)
349 ENDDO
350 ENDIF
351 ENDIF
352 DO i=n_bfgs,1,-1
353 CALL bfgs_rhd(nddl,w_ddl,bfgs_w(1,i),bfgs_v(1,i),f)
354 ENDDO
355C
356 RETURN
357 END
358!||====================================================================
359!|| bfgs_2p ../engine/source/implicit/imp_bfgs.F
360!||--- calls -----------------------------------------------------
361!|| bfgs_rhd ../engine/source/implicit/imp_bfgs.F
362!||--- uses -----------------------------------------------------
363!|| imp_bfgs ../engine/share/modules/impbufdef_mod.F
364!||====================================================================
365 SUBROUTINE bfgs_2p(NDDL,W_DDL,U,F,A2,IT,MAX_BFGS)
366C-----------------------------------------------
367C M o d u l e s
368C-----------------------------------------------
369 USE imp_bfgs
370C-----------------------------------------------
371C I m p l i c i t T y p e s
372C-----------------------------------------------
373#include "implicit_f.inc"
374C-----------------------------------------------
375C C o m m o n B l o c k s
376C-----------------------------------------------
377#include "impl1_c.inc"
378C-----------------------------------------------
379C D u m m y A r g u m e n t s
380C-----------------------------------------------
381C REAL
382 INTEGER NDDL,W_DDL(*),IT,MAX_BFGS
383 my_real
384 . f(*) ,u(*),a2
385C-----------------------------------------------
386C L o c a l V a r i a b l e s
387C-----------------------------------------------
388 INTEGER I ,N
389C------------------------------------------
390 IF (iactb==0.AND.it==0) RETURN
391 iactb = 1
392 IF (it==0.AND.l_bfgs==0) n_bfgs = 0
393C
394 IF(n_bfgs>0) THEN
395 DO i=1,n_bfgs
396 CALL bfgs_rhd(nddl,w_ddl,bfgs_v(1,i),bfgs_w(1,i),u)
397 ENDDO
398 ENDIF
399C
400 IF (l_bfgs>0) THEN
401 IF (n_bfgs<l_bfgs) THEN
402 n = n_bfgs + 1
403 DO i=1,nddl
404 bfgs_w(i,n) = u(i)
405 bfgs_v(i,n) = f(i)
406 ENDDO
407 ELSEIF (n_bfgs==l_bfgs) THEN
408 n_bfgs=l_bfgs-1
409 DO n=1,n_bfgs
410 DO i=1,nddl
411 bfgs_w(i,n) = bfgs_w(i,n+1)
412 bfgs_v(i,n) = bfgs_v(i,n+1)
413 ENDDO
414 ENDDO
415 DO i=1,nddl
416 bfgs_w(i,n_bfgs+1) = u(i)
417 bfgs_v(i,n_bfgs+1) = f(i)
418 ENDDO
419 ENDIF
420 ELSE
421 IF (n_bfgs<max_bfgs) THEN
422 n = n_bfgs + 1
423 DO i=1,nddl
424 bfgs_w(i,n) = u(i)
425 bfgs_v(i,n) = f(i)
426 ENDDO
427 ENDIF
428 ENDIF
429C
430 RETURN
431 END
432!||====================================================================
433!|| nsloan_0 ../engine/source/implicit/imp_bfgs.F
434!||--- uses -----------------------------------------------------
435!|| imp_bfgs ../engine/share/modules/impbufdef_mod.F
436!||====================================================================
437 SUBROUTINE nsloan_0(NDDL0)
438C-----------------------------------------------
439C M o d u l e s
440C-----------------------------------------------
441 USE imp_bfgs
442C-----------------------------------------------
443C I m p l i c i t T y p e s
444C-----------------------------------------------
445#include "implicit_f.inc"
446C-----------------------------------------------
447C D u m m y A r g u m e n t s
448C-----------------------------------------------
449 INTEGER NDDL0
450C REAL
451C-----------------------------------------------
452C L o c a l V a r i a b l e s
453C-----------------------------------------------
454 n_bfgs = nddl0
455 s_lin = one
456C------------------------------------------
457C
458 RETURN
459 END
460!||====================================================================
461!|| nsloan_5 ../engine/source/implicit/imp_bfgs.F
462!||--- calls -----------------------------------------------------
463!|| d_to_u ../engine/source/implicit/produt_v.F
464!|| produt_w ../engine/source/implicit/produt_v.F
465!||--- uses -----------------------------------------------------
466!|| imp_bfgs ../engine/share/modules/impbufdef_mod.F
467!||====================================================================
468 SUBROUTINE nsloan_5(NDDL ,IDDL ,NDOF ,IKC ,W_DDL ,
469 . DD ,DDR ,U ,F ,ICONV )
470C-----------------------------------------------
471C M o d u l e s
472C-----------------------------------------------
473 USE imp_bfgs
474C-----------------------------------------------
475C I m p l i c i t T y p e s
476C-----------------------------------------------
477#include "implicit_f.inc"
478C-----------------------------------------------
479C D u m m y A r g u m e n t s
480C-----------------------------------------------
481C REAL
482 INTEGER NDDL,W_DDL(*),IDDL(*) ,NDOF(*) ,IKC(*),ICONV
483 my_real
484 . dd(*) ,ddr(*),u(*),f(*)
485C-----------------------------------------------
486C L o c a l V a r i a b l e s
487C-----------------------------------------------
488 INTEGER I ,NDDL0
489 my_real
490 . uold(nddl),re,rep
491C------------------------------------------
492 IF (iconv==0) THEN
493 nddl0 = n_bfgs
494 CALL d_to_u(nddl0 ,nddl ,iddl ,ndof ,ikc ,
495 . dd ,ddr ,uold )
496 CALL produt_w(nddl,uold,uold,w_ddl,re)
497 CALL produt_w(nddl,uold,u ,w_ddl,rep)
498 s_lin = s_lin + rep/max(em20,re)
499 s_lin = max(s_lin,em10)
500 DO i=1,nddl
501 u(i) = u(i) + uold(i)
502 f(i) = bfgs_v(i,1)
503 ENDDO
504 ELSE
505 DO i=1,nddl
506 bfgs_v(i,1) = f(i)
507 ENDDO
508 ENDIF
509C
510 RETURN
511 END
512!||====================================================================
513!|| get_slin ../engine/source/implicit/imp_bfgs.F
514!||--- uses -----------------------------------------------------
515!|| imp_bfgs ../engine/share/modules/impbufdef_mod.F
516!||====================================================================
517 SUBROUTINE get_slin(FR)
518C-----------------------------------------------
519C M o d u l e s
520C-----------------------------------------------
521 USE imp_bfgs
522C-----------------------------------------------
523C I m p l i c i t T y p e s
524C-----------------------------------------------
525#include "implicit_f.inc"
526C-----------------------------------------------
527C D u m m y A r g u m e n t s
528C-----------------------------------------------
529 INTEGER NDDL0
530 my_real
531 . fr
532C-----------------------------------------------
533C L o c a l V a r i a b l e s
534C-----------------------------------------------
535 fr = s_lin
536C------------------------------------------
537C
538 RETURN
539 END
540!||====================================================================
541!|| bfgs_h1 ../engine/source/implicit/imp_bfgs.F
542!||--- called by ------------------------------------------------------
543!|| lin_solv ../engine/source/implicit/lin_solv.F
544!||--- calls -----------------------------------------------------
545!|| bfgs_rhdh ../engine/source/implicit/imp_bfgs.F
546!|| my_barrier ../engine/source/system/machine.F
547!|| produt_h ../engine/source/implicit/produt_v.F
548!||--- uses -----------------------------------------------------
549!|| imp_bfgs ../engine/share/modules/impbufdef_mod.F
550!||====================================================================
551 SUBROUTINE bfgs_h1(F_DDL,L_DDL,W_DDL,F,A2,IT,ITASK)
552C-----------------------------------------------
553C M o d u l e s
554C-----------------------------------------------
555 USE imp_bfgs
556C-----------------------------------------------
557C I m p l i c i t T y p e s
558C-----------------------------------------------
559#include "implicit_f.inc"
560C-----------------------------------------------
561C D u m m y A r g u m e n t s
562C-----------------------------------------------
563 INTEGER F_DDL,L_DDL,W_DDL(*),IT,ITASK
564 my_real
565 . f(*) ,a2
566C-----------------------------------------------
567C L o c a l V a r i a b l e s
568C-----------------------------------------------
569 INTEGER I ,N
570 my_real
571 . a1 ,b1
572C------------------------------------------
573 IF (it==0.OR.(iactb==0.AND.it<2)) RETURN
574 n = n_bfgs + 1
575C--------V->dr----------------------------------
576 a2=zero
577 DO i=f_ddl,l_ddl
578 bfgs_v(i,n) = f(i) - bfgs_v(i,n)
579 ENDDO
580 CALL produt_h(f_ddl,l_ddl,bfgs_w(1,n),bfgs_v(1,n),w_ddl,a1,
581 . itask)
582 IF (itask==0) THEN
583 IF (abs(a1)>em10) n_bfgs = n
584 END IF
585C----------------------
586 CALL my_barrier
587C---------------------
588 IF (abs(a1)>em10) THEN
589 CALL produt_h(f_ddl,l_ddl,bfgs_w(1,n),f,w_ddl,a2,itask)
590 IF (itask==0) a2 = a2*s_lin
591C--------W->b1*du----------------------------------
592 b1 = one/a1
593 DO i=f_ddl,l_ddl
594 bfgs_w(i,n) = b1*bfgs_w(i,n)
595 ENDDO
596 ENDIF
597C
598 DO i=n_bfgs,1,-1
599 CALL bfgs_rhdh(f_ddl,l_ddl,w_ddl,bfgs_w(1,i),bfgs_v(1,i),f,
600 . itask)
601 ENDDO
602C
603 RETURN
604 END
605!||====================================================================
606!|| bfgs_rhdh ../engine/source/implicit/imp_bfgs.F
607!||--- called by ------------------------------------------------------
608!|| bfgs_h1 ../engine/source/implicit/imp_bfgs.F
609!|| bfgs_h1p ../engine/source/implicit/imp_bfgs.F
610!|| bfgs_h2 ../engine/source/implicit/imp_bfgs.F
611!|| bfgs_h2p ../engine/source/implicit/imp_bfgs.F
612!||--- calls -----------------------------------------------------
613!|| produt_h ../engine/source/implicit/produt_v.F
614!||====================================================================
615 SUBROUTINE bfgs_rhdh(F_DDL,L_DDL,W_DDL,BW,BV,B,ITASK)
616C-----------------------------------------------
617C I m p l i c i t T y p e s
618C-----------------------------------------------
619#include "implicit_f.inc"
620C-----------------------------------------------
621C D u m m y A r g u m e n t s
622C-----------------------------------------------
623C REAL
624 INTEGER F_DDL,L_DDL,ITASK,W_DDL(*)
625 my_real
626 . bw(*),bv(*),b(*)
627C-----------------------------------------------
628C L o c a l V a r i a b l e s
629C-----------------------------------------------
630 INTEGER I
631 my_real
632 . a1
633C------------------------------------------
634 CALL produt_h(f_ddl,l_ddl,bw,b,w_ddl,a1,itask)
635 DO i=f_ddl,l_ddl
636 b(i) = b(i) - a1*bv(i)
637 ENDDO
638C
639 RETURN
640 END
641!||====================================================================
642!|| bfgs_h2 ../engine/source/implicit/imp_bfgs.F
643!||--- called by ------------------------------------------------------
644!|| lin_solv ../engine/source/implicit/lin_solv.F
645!||--- calls -----------------------------------------------------
646!|| bfgs_rhdh ../engine/source/implicit/imp_bfgs.F
647!|| my_barrier ../engine/source/system/machine.F
648!||--- uses -----------------------------------------------------
649!|| imp_bfgs ../engine/share/modules/impbufdef_mod.F
650!||====================================================================
651 SUBROUTINE bfgs_h2(F_DDL,L_DDL,W_DDL,U,F,A2,IT,MAX_BFGS,ITASK)
652C-----------------------------------------------
653C M o d u l e s
654C-----------------------------------------------
655 USE imp_bfgs
656C-----------------------------------------------
657C I m p l i c i t T y p e s
658C-----------------------------------------------
659#include "implicit_f.inc"
660C-----------------------------------------------
661C C o m m o n B l o c k s
662C-----------------------------------------------
663#include "impl1_c.inc"
664C-----------------------------------------------
665C D u m m y A r g u m e n t s
666C-----------------------------------------------
667C REAL
668 INTEGER F_DDL,L_DDL,W_DDL(*),IT,MAX_BFGS,ITASK
669 my_real
670 . f(*) ,u(*),a2
671C-----------------------------------------------
672C L o c a l V a r i a b l e s
673C-----------------------------------------------
674 INTEGER I ,N
675C------------------------------------------
676 IF (iactb==0.AND.it==0) RETURN
677C----------------------
678 CALL my_barrier
679C---------------------
680 IF (itask==0) THEN
681 iactb = 1
682 IF (it==0.AND.l_bfgs==0) n_bfgs = 0
683 END IF !(ITASK==0) THEN
684C----------------------
685 CALL my_barrier
686C---------------------
687 IF(n_bfgs>0) THEN
688 DO i=1,n_bfgs
689 CALL bfgs_rhdh(f_ddl,l_ddl,w_ddl,bfgs_v(1,i),bfgs_w(1,i),u,
690 . itask)
691 ENDDO
692 IF (a2/=zero) THEN
693 DO i=f_ddl,l_ddl
694 u(i) = u(i) - a2*bfgs_w(i,n_bfgs)
695 ENDDO
696 ENDIF
697 ENDIF
698C
699 IF (l_bfgs>0) THEN
700 IF (n_bfgs<l_bfgs) THEN
701 n = n_bfgs + 1
702 DO i=f_ddl,l_ddl
703 bfgs_w(i,n) = u(i)
704 bfgs_v(i,n) = f(i)
705 ENDDO
706 ELSEIF (n_bfgs==l_bfgs) THEN
707 DO n=1,n_bfgs-1
708 DO i=f_ddl,l_ddl
709 bfgs_w(i,n) = bfgs_w(i,n+1)
710 bfgs_v(i,n) = bfgs_v(i,n+1)
711 ENDDO
712 ENDDO
713 DO i=f_ddl,l_ddl
714 bfgs_w(i,n_bfgs) = u(i)
715 bfgs_v(i,n_bfgs) = f(i)
716 ENDDO
717 ENDIF
718 ELSE
719C
720 IF (n_bfgs<max_bfgs) THEN
721 n = n_bfgs + 1
722 DO i=f_ddl,l_ddl
723 bfgs_w(i,n) = u(i)
724 bfgs_v(i,n) = f(i)
725 ENDDO
726 ELSEIF (n_bfgs==max_bfgs) THEN
727 DO n=1,n_bfgs-1
728 DO i=f_ddl,l_ddl
729 bfgs_w(i,n) = bfgs_w(i,n+1)
730 bfgs_v(i,n) = bfgs_v(i,n+1)
731 ENDDO
732 ENDDO
733 DO i=f_ddl,l_ddl
734 bfgs_w(i,n_bfgs) = u(i)
735 bfgs_v(i,n_bfgs) = f(i)
736 ENDDO
737 END IF !IF (N_BFGS<MAX_BFGS)
738C
739 END IF !IF (L_BFGS>0)
740C----------------------
741 CALL my_barrier
742C---------------------
743 IF (itask==0) THEN
744 IF (l_bfgs>0) THEN
745 IF (n_bfgs==l_bfgs) n_bfgs=l_bfgs-1
746 ELSEIF (n_bfgs==max_bfgs) THEN
747 n_bfgs=max_bfgs-1
748 END IF
749 END IF !(ITASK==0) THEN
750C
751 RETURN
752 END
753!||====================================================================
754!|| bfgs_h1p ../engine/source/implicit/imp_bfgs.F
755!||--- called by ------------------------------------------------------
756!|| lin_solv ../engine/source/implicit/lin_solv.F
757!||--- calls -----------------------------------------------------
758!|| bfgs_rhdh ../engine/source/implicit/imp_bfgs.F
759!|| my_barrier ../engine/source/system/machine.F
760!|| produt_h ../engine/source/implicit/produt_v.F
761!||--- uses -----------------------------------------------------
762!|| imp_bfgs ../engine/share/modules/impbufdef_mod.F
763!||====================================================================
764 SUBROUTINE bfgs_h1p(F_DDL,L_DDL,W_DDL,F,A2,IT,ITASK)
765C-----------------------------------------------
766C M o d u l e s
767C-----------------------------------------------
768 USE imp_bfgs
769C-----------------------------------------------
770C I m p l i c i t T y p e s
771C-----------------------------------------------
772#include "implicit_f.inc"
773C-----------------------------------------------
774C D u m m y A r g u m e n t s
775C-----------------------------------------------
776C REAL
777 INTEGER F_DDL,L_DDL,ITASK,W_DDL(*),IT
778 my_real
779 . f(*) ,a2
780C-----------------------------------------------
781C L o c a l V a r i a b l e s
782C-----------------------------------------------
783 INTEGER I ,N
784 my_real
785 . a0,a1 ,b1
786C------------------------------------------
787 IF (it==0.OR.(iactb==0.AND.it<2)) RETURN
788 n = n_bfgs + 1
789C--------V->dr----------------------------------
790 DO i=f_ddl,l_ddl
791 bfgs_v(i,n) = f(i) - bfgs_v(i,n)
792 ENDDO
793 CALL produt_h(f_ddl,l_ddl,bfgs_w(1,n),bfgs_v(1,n),w_ddl,a0,
794 . itask)
795 CALL produt_h(f_ddl,l_ddl,bfgs_w(1,n),f,w_ddl,a2,itask)
796C
797 a1 = s_lin*a0
798 IF (itask==0) THEN
799 IF (abs(a2)>em10) THEN
800 b1=-a1/a2
801 IF (abs(a1)>em10.AND.b1>zero) n_bfgs = n
802 END IF
803 END IF
804C----------------------
805 CALL my_barrier
806C---------------------
807 IF (abs(a2)>em10) THEN
808 b1=-a1/a2
809 IF (abs(a1)>em10.AND.b1>zero) THEN
810C--------W->b1*du----------------------------------
811 b1 = sqrt(b1)
812 DO i=f_ddl,l_ddl
813 bfgs_w(i,n) = bfgs_w(i,n)/a1
814 bfgs_v(i,n) = bfgs_v(i,n)-b1*f(i)
815 ENDDO
816 ENDIF
817 ENDIF
818C----------------------
819 CALL my_barrier
820C---------------------
821 DO i=n_bfgs,1,-1
822 CALL bfgs_rhdh(f_ddl,l_ddl,w_ddl,bfgs_w(1,i),bfgs_v(1,i),f,
823 . itask)
824 ENDDO
825C
826 RETURN
827 END
828!||====================================================================
829!|| bfgs_h2p ../engine/source/implicit/imp_bfgs.F
830!||--- called by ------------------------------------------------------
831!|| lin_solv ../engine/source/implicit/lin_solv.F
832!||--- calls -----------------------------------------------------
833!|| bfgs_rhdh ../engine/source/implicit/imp_bfgs.F
834!|| my_barrier ../engine/source/system/machine.F
835!||--- uses -----------------------------------------------------
836!|| imp_bfgs ../engine/share/modules/impbufdef_mod.F
837!||====================================================================
838 SUBROUTINE bfgs_h2p(F_DDL,L_DDL,W_DDL,U,F,A2,IT,MAX_BFGS,ITASK)
839C-----------------------------------------------
840C M o d u l e s
841C-----------------------------------------------
842 USE imp_bfgs
843C-----------------------------------------------
844C I m p l i c i t T y p e s
845C-----------------------------------------------
846#include "implicit_f.inc"
847C-----------------------------------------------
848C C o m m o n B l o c k s
849C-----------------------------------------------
850#include "impl1_c.inc"
851C-----------------------------------------------
852C D u m m y A r g u m e n t s
853C-----------------------------------------------
854C REAL
855 INTEGER F_DDL,L_DDL,ITASK,W_DDL(*),IT,MAX_BFGS
856 my_real
857 . f(*) ,u(*),a2
858C-----------------------------------------------
859C L o c a l V a r i a b l e s
860C-----------------------------------------------
861 INTEGER I ,N
862C------------------------------------------
863 IF (iactb==0.AND.it==0) RETURN
864C----------------------
865 CALL my_barrier
866C---------------------
867 IF (itask==0) THEN
868 iactb = 1
869 IF (it==0.AND.l_bfgs==0) n_bfgs = 0
870 END IF !(ITASK==0) THEN
871C----------------------
872 CALL my_barrier
873C---------------------
874 IF(n_bfgs>0) THEN
875 DO i=1,n_bfgs
876 CALL bfgs_rhdh(f_ddl,l_ddl,w_ddl,bfgs_v(1,i),bfgs_w(1,i),u,
877 . itask)
878 ENDDO
879 ENDIF
880C
881 IF (l_bfgs>0) THEN
882 IF (n_bfgs<l_bfgs) THEN
883 n = n_bfgs + 1
884 DO i=f_ddl,l_ddl
885 bfgs_w(i,n) = u(i)
886 bfgs_v(i,n) = f(i)
887 ENDDO
888 ELSEIF (n_bfgs==l_bfgs) THEN
889 DO n=1,n_bfgs-1
890 DO i=f_ddl,l_ddl
891 bfgs_w(i,n) = bfgs_w(i,n+1)
892 bfgs_v(i,n) = bfgs_v(i,n+1)
893 ENDDO
894 ENDDO
895 DO i=f_ddl,l_ddl
896 bfgs_w(i,n_bfgs) = u(i)
897 bfgs_v(i,n_bfgs) = f(i)
898 ENDDO
899 ENDIF
900 ELSE
901 IF (n_bfgs<max_bfgs) THEN
902 n = n_bfgs + 1
903 DO i=f_ddl,l_ddl
904 bfgs_w(i,n) = u(i)
905 bfgs_v(i,n) = f(i)
906 ENDDO
907 ELSEIF (n_bfgs==max_bfgs) THEN
908 DO n=1,n_bfgs-1
909 DO i=f_ddl,l_ddl
910 bfgs_w(i,n) = bfgs_w(i,n+1)
911 bfgs_v(i,n) = bfgs_v(i,n+1)
912 ENDDO
913 ENDDO
914 DO i=f_ddl,l_ddl
915 bfgs_w(i,n_bfgs) = u(i)
916 bfgs_v(i,n_bfgs) = f(i)
917 ENDDO
918 END IF !IF (n_bfgs<max_bfgs)
919 END IF !IF (L_BFGS>0)
920C----------------------
921 CALL my_barrier
922C---------------------
923 IF (itask==0) THEN
924 IF (l_bfgs>0) THEN
925 IF (n_bfgs==l_bfgs) n_bfgs=l_bfgs-1
926 ELSEIF (n_bfgs==max_bfgs) THEN
927 n_bfgs=max_bfgs-1
928 END IF
929 END IF !(ITASK==0) THEN
930C
931 RETURN
932 END
933
my_real
#define my_real
Definition cppsort.cpp:32
bfgs_0
subroutine bfgs_0
Definition imp_bfgs.F:81
bfgs_h1
subroutine bfgs_h1(f_ddl, l_ddl, w_ddl, f, a2, it, itask)
Definition imp_bfgs.F:552
get_slin
subroutine get_slin(fr)
Definition imp_bfgs.F:518
bfgs_h2
subroutine bfgs_h2(f_ddl, l_ddl, w_ddl, u, f, a2, it, max_bfgs, itask)
Definition imp_bfgs.F:652
nsloan_0
subroutine nsloan_0(nddl0)
Definition imp_bfgs.F:438
bfgs_2
subroutine bfgs_2(nddl, w_ddl, u, f, a2, it, max_bfgs)
Definition imp_bfgs.F:231
bfgs_h2p
subroutine bfgs_h2p(f_ddl, l_ddl, w_ddl, u, f, a2, it, max_bfgs, itask)
Definition imp_bfgs.F:839
bfgs_1p
subroutine bfgs_1p(nddl, w_ddl, f, a2, it)
Definition imp_bfgs.F:309
bfgs_ls
subroutine bfgs_ls(ls)
Definition imp_bfgs.F:109
bfgs_rhdh
subroutine bfgs_rhdh(f_ddl, l_ddl, w_ddl, bw, bv, b, itask)
Definition imp_bfgs.F:616
bfgs_2p
subroutine bfgs_2p(nddl, w_ddl, u, f, a2, it, max_bfgs)
Definition imp_bfgs.F:366
bfgs_h1p
subroutine bfgs_h1p(f_ddl, l_ddl, w_ddl, f, a2, it, itask)
Definition imp_bfgs.F:765
bfgs_rhd
subroutine bfgs_rhd(nddl, w_ddl, bw, bv, b)
Definition imp_bfgs.F:197
bfgs_1
subroutine bfgs_1(nddl, w_ddl, f, a2, it)
Definition imp_bfgs.F:140
bfgs_ini
subroutine bfgs_ini(nddl, max_bfgs)
Definition imp_bfgs.F:31
nsloan_5
subroutine nsloan_5(nddl, iddl, ndof, ikc, w_ddl, dd, ddr, u, f, iconv)
Definition imp_bfgs.F:470
max
#define max(a, b)
Definition macros.h:21
imp_bfgs
Definition impbufdef_mod.F:269
imp_bfgs::iactb
integer iactb
Definition impbufdef_mod.F:272
imp_bfgs::n_bfgs
integer n_bfgs
Definition impbufdef_mod.F:272
impbufdef_mod
Definition impbufdef_mod.F:36
d_to_u
subroutine d_to_u(nddl0, nddl, iddl, ndof, ikc, d, dr, u)
Definition produt_v.F:154
produt_w
subroutine produt_w(nddl, x, y, w, r)
Definition produt_v.F:106
produt_h
subroutine produt_h(f_ddl, l_ddl, x, y, w, r, itask)
Definition produt_v.F:1533
my_barrier
subroutine my_barrier
Definition machine.F:31