OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
imp_bfgs.F File Reference
#include "implicit_f.inc"
#include "impl1_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine bfgs_ini (nddl, max_bfgs)
subroutine bfgs_0
subroutine bfgs_ls (ls)
subroutine bfgs_1 (nddl, w_ddl, f, a2, it)
subroutine bfgs_rhd (nddl, w_ddl, bw, bv, b)
subroutine bfgs_2 (nddl, w_ddl, u, f, a2, it, max_bfgs)
subroutine bfgs_1p (nddl, w_ddl, f, a2, it)
subroutine bfgs_2p (nddl, w_ddl, u, f, a2, it, max_bfgs)
subroutine nsloan_0 (nddl0)
subroutine nsloan_5 (nddl, iddl, ndof, ikc, w_ddl, dd, ddr, u, f, iconv)
subroutine get_slin (fr)
subroutine bfgs_h1 (f_ddl, l_ddl, w_ddl, f, a2, it, itask)
subroutine bfgs_rhdh (f_ddl, l_ddl, w_ddl, bw, bv, b, itask)
subroutine bfgs_h2 (f_ddl, l_ddl, w_ddl, u, f, a2, it, max_bfgs, itask)
subroutine bfgs_h1p (f_ddl, l_ddl, w_ddl, f, a2, it, itask)
subroutine bfgs_h2p (f_ddl, l_ddl, w_ddl, u, f, a2, it, max_bfgs, itask)

Function/Subroutine Documentation

◆ bfgs_0()

subroutine bfgs_0

Definition at line 80 of file imp_bfgs.F.

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
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

◆ bfgs_1()

subroutine bfgs_1 ( integer nddl,
integer, dimension(*) w_ddl,
f,
a2,
integer it )

Definition at line 139 of file imp_bfgs.F.

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
my_real
#define my_real
Definition cppsort.cpp:32
bfgs_rhd
subroutine bfgs_rhd(nddl, w_ddl, bw, bv, b)
Definition imp_bfgs.F:197
produt_w
subroutine produt_w(nddl, x, y, w, r)
Definition produt_v.F:106

◆ bfgs_1p()

subroutine bfgs_1p ( integer nddl,
integer, dimension(*) w_ddl,
f,
a2,
integer it )

Definition at line 308 of file imp_bfgs.F.

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

◆ bfgs_2()

subroutine bfgs_2 ( integer nddl,
integer, dimension(*) w_ddl,
u,
f,
a2,
integer it,
integer max_bfgs )

Definition at line 230 of file imp_bfgs.F.

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

◆ bfgs_2p()

subroutine bfgs_2p ( integer nddl,
integer, dimension(*) w_ddl,
u,
f,
a2,
integer it,
integer max_bfgs )

Definition at line 365 of file imp_bfgs.F.

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

◆ bfgs_h1()

subroutine bfgs_h1 ( integer f_ddl,
integer l_ddl,
integer, dimension(*) w_ddl,
f,
a2,
integer it,
integer itask )

Definition at line 551 of file imp_bfgs.F.

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
bfgs_rhdh
subroutine bfgs_rhdh(f_ddl, l_ddl, w_ddl, bw, bv, b, itask)
Definition imp_bfgs.F:616
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

◆ bfgs_h1p()

subroutine bfgs_h1p ( integer f_ddl,
integer l_ddl,
integer, dimension(*) w_ddl,
f,
a2,
integer it,
integer itask )

Definition at line 764 of file imp_bfgs.F.

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

◆ bfgs_h2()

subroutine bfgs_h2 ( integer f_ddl,
integer l_ddl,
integer, dimension(*) w_ddl,
u,
f,
a2,
integer it,
integer max_bfgs,
integer itask )

Definition at line 651 of file imp_bfgs.F.

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

◆ bfgs_h2p()

subroutine bfgs_h2p ( integer f_ddl,
integer l_ddl,
integer, dimension(*) w_ddl,
u,
f,
a2,
integer it,
integer max_bfgs,
integer itask )

Definition at line 838 of file imp_bfgs.F.

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

◆ bfgs_ini()

subroutine bfgs_ini ( integer nddl,
integer max_bfgs )

Definition at line 30 of file imp_bfgs.F.

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

◆ bfgs_ls()

subroutine bfgs_ls ( ls)

Definition at line 108 of file imp_bfgs.F.

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

◆ bfgs_rhd()

subroutine bfgs_rhd ( integer nddl,
integer, dimension(*) w_ddl,
bw,
bv,
b )

Definition at line 196 of file imp_bfgs.F.

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

◆ bfgs_rhdh()

subroutine bfgs_rhdh ( integer f_ddl,
integer l_ddl,
integer, dimension(*) w_ddl,
bw,
bv,
b,
integer itask )

Definition at line 615 of file imp_bfgs.F.

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

◆ get_slin()

subroutine get_slin ( fr)

Definition at line 517 of file imp_bfgs.F.

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

◆ nsloan_0()

subroutine nsloan_0 ( integer nddl0)

Definition at line 437 of file imp_bfgs.F.

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

◆ nsloan_5()

subroutine nsloan_5 ( integer nddl,
integer, dimension(*) iddl,
integer, dimension(*) ndof,
integer, dimension(*) ikc,
integer, dimension(*) w_ddl,
dd,
ddr,
u,
f,
integer iconv )

Definition at line 468 of file imp_bfgs.F.

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
max
#define max(a, b)
Definition macros.h:21
d_to_u
subroutine d_to_u(nddl0, nddl, iddl, ndof, ikc, d, dr, u)
Definition produt_v.F:154