OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
imp_fsa_inv.F File Reference
#include "implicit_f.inc"
#include "vectorize.inc"
#include "impl2_c.inc"
#include "task_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine sp_stat0 (il, iadk, jdik, nc, jm)
subroutine sp_static (nddl, iadk, jdik, diag_k, lt_k, iadm, jdim, nnzm, nc, jm, maxc, psi, ip)
subroutine sp_a2 (nddl, nc, jm, maxc, ifsai)
subroutine imp_fsai (n, iada, jdia, diag_a, lt_a, maxa, mj)
subroutine get_subs0 (nddl, iadk, jdik, diag_k, lt_k, nc, iada, jdia, diag_a, lt_a, jm, maxa)
subroutine get_subsp (nddl, iadk, jdik, diag_k, lt_k, nc, iada, jdia, diag_a, lt_a, jm, maxa, idlft0, idlft1, diag_c, lt_c, diag_m, lt_m)
subroutine get_subsa (nddl, iadk, jdik, diag_k, lt_k, nc, iada, jdia, diag_a, lt_a, jm)
integer function intab0 (nic, ic, n)
integer function intab2 (nic1, ic1, nic2, ic2)
subroutine imp_fsa_invp (nddl, nnz, iadk, jdik, diag_k, lt_k, diag_m, lt_m, maxc, max_a, nne, idlft0, idlft1, max_d)
subroutine imp_pcg1 (nddl, nnz, iadk, jdik, diag_k, lt_k, r, isp)
subroutine imp_fsa_inv2 (nddl, iadk, jdik, diag_k, lt_k, iadm, jdim, diag_m, lt_m, maxc, max_a, nne, d_tol, p_mach)
subroutine imp_fsa_invp2 (nddl, iadk, jdik, diag_k, lt_k, iadm, jdim, diag_m, lt_m, maxc, max_a, nne, idlft0, idlft1, max_d, d_tol, p_mach)
subroutine imp_kfiltr (ndf, nd, iada, jdia, diag_a, lt_a, tol, e_ps, diag_k)
subroutine get_subsn (nddl, iadk, jdik, diag_k, lt_k, nc, iada, jdia, diag_a, lt_a, jm, maxa)
subroutine ind_lt2ln (nddl, iadk, jdik, lt_k, maxl)
subroutine imp_fsa_invh (nddl, nnz, iadk, jdik, diag_k, lt_k, diag_m, lt_m, maxc, max_a, nne, idlft0, idlft1, max_d, itask)
subroutine imp_fsa_invh2 (nddl, iadk, jdik, diag_k, lt_k, iadm, jdim, diag_m, lt_m, maxc, max_a, nne, idlft0, idlft1, max_d, d_tol, p_mach, itask)
subroutine sp_dim (il, iadk, jdik, nc, max_a, max_l)
subroutine fsa_solv (nddl, nc, iadk, jdik, diag_k, lt_k, diag_m, lt_m, diag_c, lt_c, max_a, idlft0, idlft1, nne, i_chk, iadm, jdim, i)
subroutine imp_fsa_invhp (nddl, nnz, iadk, jdik, diag_k, lt_k, diag_m, lt_m, maxc, max_a, nne, idlft0, idlft1, max_d)
subroutine imp_fsa_inv2hp (nddl, iadk, jdik, diag_k, lt_k, iadm, jdim, diag_m, lt_m, maxc, max_a, nne, idlft0, idlft1, max_d, d_tol, p_mach)

Function/Subroutine Documentation

◆ fsa_solv()

subroutine fsa_solv ( integer nddl,
integer nc,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
diag_k,
lt_k,
diag_m,
lt_m,
diag_c,
lt_c,
integer max_a,
integer idlft0,
integer idlft1,
integer nne,
integer i_chk,
integer, dimension(*) iadm,
integer, dimension(*) jdim,
integer i )

Definition at line 1626 of file imp_fsa_inv.F.

1631C-----------------------------------------------
1632C I m p l i c i t T y p e s
1633C-----------------------------------------------
1634#include "implicit_f.inc"
1635C-----------------------------------------------
1636C D u m m y A r g u m e n t s
1637C-----------------------------------------------
1638 INTEGER I,NDDL ,NC ,IADK(*),JDIK(*),MAX_A ,NNE,
1639 . IDLFT0,IDLFT1 ,I_CHK,IADM(*),JDIM(*)
1640C REAL
1641 my_real
1642 . diag_k(*), lt_k(*),diag_m(*), lt_m(*) ,diag_c(*),lt_c(*)
1643C-----------------------------------------------
1644C L o c a l V a r i a b l e s
1645C-----------------------------------------------
1646C--- M->A^-1 LT_M strictly lower in m.c.r.s. format
1647 INTEGER J,K,M,N,MAX_L,IERR,IER1,IADA(NC+1),JM(NC)
1648c . IADA(NC+1),JDIA(MAX_A),JM(NC)
1649c my_real
1650c . DIAG_A(NC),LT_A(MAX_A),MJ(NC)
1651 INTEGER, DIMENSION(:),ALLOCATABLE :: JDIA
1652 my_real, DIMENSION(:),ALLOCATABLE :: diag_a,lt_a,mj
1653C-----------------------------
1654C
1655 ALLOCATE(diag_a(nc),mj(nc),stat=ier1)
1656 ALLOCATE(lt_a(max_a),jdia(max_a),stat=ierr)
1657C-----------------------------
1658 j=0
1659 DO k =iadm(i),iadm(i+1)-1
1660 j=j+1
1661 jm(j)=jdim(k)
1662 ENDDO
1663 j=j+1
1664 jm(j)=i
1665C
1666 CALL get_subsp(nddl ,iadk ,jdik ,diag_k ,lt_k ,
1667 . nc ,iada ,jdia ,diag_a ,lt_a ,
1668 . jm ,max_a ,idlft0,idlft1 ,diag_c,
1669 . lt_c ,diag_m ,lt_m )
1670 DO j=1,nc-1
1671 mj(j)=zero
1672 ENDDO
1673 mj(nc)=one
1674C
1675 IF (nc > 10000) THEN
1676 max_l=max_a
1677 CALL imp_pcg1(
1678 1 nc ,max_l ,iada ,jdia ,diag_a ,
1679 2 lt_a ,mj ,ierr )
1680C
1681 IF (i_chk>0.AND.ierr<0) nne = i
1682 ELSE
1683C
1684 max_l=1+(nc*(nc-1))/2
1685 CALL imp_fsai(nc ,iada ,jdia ,diag_a ,lt_a ,
1686 . max_l ,mj )
1687C
1688 ENDIF
1689C------------filtrage----Diagonal est dans LT_M (last one)--
1690 diag_m(i)=mj(nc)
1691 IF (diag_m(i)<em20) THEN
1692 IF (nne==0.AND.i_chk==0) nne = i
1693 diag_m(i)=abs(diag_m(i))
1694 diag_m(i)=max(em20,diag_m(i))
1695 ENDIF
1696 DO k =1,nc-1
1697 m=iadm(i)+k-1
1698 lt_m(m)=mj(k)/diag_m(i)
1699 ENDDO
1700 IF (i_chk>0.AND.mj(nc)<em20) diag_m(i)=mj(nc)
1701C
1702 DEALLOCATE(diag_a,mj)
1703 DEALLOCATE(lt_a,jdia)
1704 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
get_subsp
subroutine get_subsp(nddl, iadk, jdik, diag_k, lt_k, nc, iada, jdia, diag_a, lt_a, jm, maxa, idlft0, idlft1, diag_c, lt_c, diag_m, lt_m)
Definition imp_fsa_inv.F:372
imp_pcg1
subroutine imp_pcg1(nddl, nnz, iadk, jdik, diag_k, lt_k, r, isp)
Definition imp_fsa_inv.F:693
imp_fsai
subroutine imp_fsai(n, iada, jdia, diag_a, lt_a, maxa, mj)
Definition imp_fsa_inv.F:267
max
#define max(a, b)
Definition macros.h:21

◆ get_subs0()

subroutine get_subs0 ( integer nddl,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
diag_k,
lt_k,
integer nc,
integer, dimension(*) iada,
integer, dimension(*) jdia,
diag_a,
lt_a,
integer, dimension(*) jm,
integer maxa )

Definition at line 310 of file imp_fsa_inv.F.

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-----------------------------------------------
320 INTEGER NDDL ,IADK(*) ,JDIK(*),IADA(*) ,JDIA(*)
321 INTEGER NC ,JM(*),MAXA
322C REAL
323 my_real
324 . lt_k(*),diag_k(*),lt_a(*),diag_a(*)
325C-----------------------------------------------
326C External function
327C-----------------------------------------------
328 INTEGER INTAB0
329 EXTERNAL intab0
330C-----------------------------------------------
331C L o c a l V a r i a b l e s
332C-----------------------------------------------
333 INTEGER I,J,K,JJ,NNZA,N
334C--------------------------------------------
335 nnza=0
336 iada(1)=1
337 DO i=1,nc
338 j=jm(i)
339 diag_a(i)=diag_k(j)
340 DO k=iadk(j),iadk(j+1)-1
341 jj=jdik(k)
342 n=intab0(nc,jm,jj)
343 IF (n>0) THEN
344 nnza=nnza+1
345 jdia(nnza)=n
346 lt_a(nnza)=lt_k(k)
347 ENDIF
348 ENDDO
349 iada(i+1)=nnza+1
350 ENDDO
351 CALL ind_lt2ln(nc,iada ,jdia ,lt_a, nnza )
352C
353 RETURN
intab0
integer function intab0(nic, ic, n)
Definition imp_fsa_inv.F:509
ind_lt2ln
subroutine ind_lt2ln(nddl, iadk, jdik, lt_k, maxl)
Definition imp_fsa_inv.F:1285

◆ get_subsa()

subroutine get_subsa ( integer nddl,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
diag_k,
lt_k,
integer nc,
integer, dimension(*) iada,
integer, dimension(*) jdia,
diag_a,
lt_a,
integer, dimension(*) jm )

Definition at line 450 of file imp_fsa_inv.F.

453C-----------------------------------------------
454C I m p l i c i t T y p e s
455C-----------------------------------------------
456#include "implicit_f.inc"
457C-----------------------------------------------
458C D u m m y A r g u m e n t s
459C-----------------------------------------------
460 INTEGER NDDL ,IADK(*) ,JDIK(*),IADA(*) ,JDIA(*)
461 INTEGER NC ,JM(*)
462C REAL
463 my_real
464 . lt_k(*),diag_k(*),lt_a(*),diag_a(*)
465C-----------------------------------------------
466C External function
467C-----------------------------------------------
468 INTEGER INTAB0
469 EXTERNAL intab0
470C-----------------------------------------------
471C L o c a l V a r i a b l e s
472C-----------------------------------------------
473 INTEGER I,J,K,JJ,NNZA,N
474C--------------------------------------------
475 nnza=0
476 iada(1)=1
477 DO i=1,nc
478 j=jm(i)
479 diag_a(i)=diag_k(j)
480 DO k=iadk(j),iadk(j+1)-1
481 jj=jdik(k)
482 n=intab0(nc,jm,jj)
483 IF (n>0) THEN
484 nnza=nnza+1
485 jdia(nnza)=n
486 lt_a(nnza)=lt_k(k)
487 ENDIF
488 ENDDO
489 iada(i+1)=nnza+1
490 ENDDO
491C
492 RETURN

◆ get_subsn()

subroutine get_subsn ( integer nddl,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
diag_k,
lt_k,
integer nc,
integer, dimension(*) iada,
integer, dimension(*) jdia,
diag_a,
lt_a,
integer, dimension(*) jm,
integer maxa )

Definition at line 1225 of file imp_fsa_inv.F.

1228C-----------------------------------------------
1229C I m p l i c i t T y p e s
1230C-----------------------------------------------
1231#include "implicit_f.inc"
1232C-----------------------------------------------
1233C D u m m y A r g u m e n t s
1234C-----------------------------------------------
1235 INTEGER NDDL ,IADK(*) ,JDIK(*),IADA(*) ,JDIA(*)
1236 INTEGER NC ,JM(*),MAXA
1237C REAL
1238 my_real
1239 . lt_k(*),diag_k(*),lt_a(*),diag_a(*)
1240C-----------------------------------------------
1241C External function
1242C-----------------------------------------------
1243 INTEGER INTAB0
1244 EXTERNAL intab0
1245C-----------------------------------------------
1246C L o c a l V a r i a b l e s
1247C-----------------------------------------------
1248 INTEGER I,J,K,JJ,NNZA,N
1249 my_real
1250 . dd
1251C--------------------------------------------
1252 nnza=0
1253 iada(1)=1
1254 DO i=1,nc
1255 j=jm(i)
1256 diag_a(i)=one
1257 DO k=iadk(j),iadk(j+1)-1
1258 jj=jdik(k)
1259 n=intab0(nc,jm,jj)
1260 IF (n>0) THEN
1261 dd = sqrt(diag_k(j)*diag_k(jj))
1262 nnza=nnza+1
1263 jdia(nnza)=n
1264 lt_a(nnza)=lt_k(k)/dd
1265 ENDIF
1266 ENDDO
1267 iada(i+1)=nnza+1
1268 ENDDO
1269 CALL ind_lt2ln(nc,iada ,jdia ,lt_a, nnza )
1270C
1271 RETURN

◆ get_subsp()

subroutine get_subsp ( integer nddl,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
diag_k,
lt_k,
integer nc,
integer, dimension(*) iada,
integer, dimension(*) jdia,
diag_a,
lt_a,
integer, dimension(*) jm,
integer maxa,
integer idlft0,
integer idlft1,
diag_c,
lt_c,
diag_m,
lt_m )

Definition at line 368 of file imp_fsa_inv.F.

372C-----------------------------------------------
373C I m p l i c i t T y p e s
374C-----------------------------------------------
375#include "implicit_f.inc"
376C-----------------------------------------------
377C D u m m y A r g u m e n t s
378C-----------------------------------------------
379 INTEGER NDDL ,IADK(*) ,JDIK(*),IADA(*) ,JDIA(*)
380 INTEGER NC ,JM(*),MAXA,IDLFT0,IDLFT1
381C REAL
382 my_real
383 . lt_k(*),diag_k(*),lt_a(*),diag_a(*),lt_c(*),diag_c(*),
384 . diag_m(*) ,lt_m(*)
385C-----------------------------------------------
386C External function
387C-----------------------------------------------
388 INTEGER INTAB0
389 EXTERNAL intab0
390C-----------------------------------------------
391C L o c a l V a r i a b l e s
392C-----------------------------------------------
393 INTEGER I,J,K,JJ,NNZA,N,K0
394C--------------------------------------------
395 nnza=0
396 iada(1)=1
397 k0=iadk(idlft1+1)-1
398#include "vectorize.inc"
399 DO i=1,nc
400 j=jm(i)
401 IF (j<=idlft0) THEN
402 diag_a(i)=diag_m(j)
403 DO k=iadk(j),iadk(j+1)-1
404 jj=jdik(k)
405 n=intab0(nc,jm,jj)
406 IF (n>0) THEN
407 nnza=nnza+1
408 jdia(nnza)=n
409 lt_a(nnza)=lt_m(k)
410 ENDIF
411 ENDDO
412 ELSEIF (j>idlft1) THEN
413 diag_a(i)=diag_c(j-idlft1)
414 DO k=iadk(j),iadk(j+1)-1
415 jj=jdik(k)
416C IF (JJ>IDLFT1) THEN
417 n=intab0(nc,jm,jj)
418 IF (n>0) THEN
419 nnza=nnza+1
420 jdia(nnza)=n
421 lt_a(nnza)=lt_c(k-k0)
422 ENDIF
423C ENDIF
424 ENDDO
425 ELSE
426 diag_a(i)=diag_k(j)
427 DO k=iadk(j),iadk(j+1)-1
428 jj=jdik(k)
429 n=intab0(nc,jm,jj)
430 IF (n>0) THEN
431 nnza=nnza+1
432 jdia(nnza)=n
433 lt_a(nnza)=lt_k(k)
434 ENDIF
435 ENDDO
436 ENDIF
437 iada(i+1)=nnza+1
438 ENDDO
439C CALL IND_LT2L(NC,IADA ,JDIA ,LT_A, NNZA )
440 CALL ind_lt2ln(nc,iada ,jdia ,lt_a, nnza )
441C
442 RETURN

◆ imp_fsa_inv2()

subroutine imp_fsa_inv2 ( integer nddl,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
diag_k,
lt_k,
integer, dimension(*) iadm,
integer, dimension(*) jdim,
diag_m,
lt_m,
integer maxc,
integer max_a,
integer nne,
d_tol,
p_mach )

Definition at line 923 of file imp_fsa_inv.F.

927C-----------------------------------------------
928C M o d u l e s
929C-----------------------------------------------
930 USE message_mod
931C-----------------------------------------------
932C I m p l i c i t T y p e s
933C-----------------------------------------------
934#include "implicit_f.inc"
935C-----------------------------------------------
936C D u m m y A r g u m e n t s
937C-----------------------------------------------
938 INTEGER NDDL ,IADK(*),JDIK(*),MAXC ,MAX_A ,NNE,
939 . IADM(*),JDIM(*)
940C REAL
941 my_real
942 . diag_k(*), lt_k(*),diag_m(*), lt_m(*) ,d_tol ,p_mach
943C-----------------------------------------------
944C L o c a l V a r i a b l e s
945C-----------------------------------------------
946C--- M->A^-1 LT_M strictly lower in m.c.r.s. format
947 INTEGER I,J,K,M,N,NC,IERR
948 INTEGER MAX_L,I_CHK
949 INTEGER, DIMENSION(:),ALLOCATABLE :: IADA,JDIA,JM
950 my_real, DIMENSION(:),ALLOCATABLE :: diag_a,lt_a,mj
951C-----------------------------
952 i_chk = nne
953 nne = 0
954 ALLOCATE(iada(maxc+1))
955 ALLOCATE(jdia(max_a))
956 ALLOCATE(jm(maxc+1))
957 ALLOCATE(diag_a(maxc))
958 ALLOCATE(mj(maxc))
959 ALLOCATE(lt_a(max_a),stat=ierr)
960 IF (ierr/=0) THEN
961 CALL ancmsg(msgid=19,anmode=aninfo,
962 . c1='FOR IMPLICIT PRECONDITION')
963 CALL arret(2)
964 ENDIF
965 DO i=1,nddl
966 CALL sp_stat0(i ,iadm ,jdim ,nc ,jm )
967 CALL get_subs0(nddl ,iadk ,jdik ,diag_k ,lt_k ,
968 . nc ,iada ,jdia ,diag_a ,lt_a ,
969 . jm ,max_a )
970 DO j=1,nc-1
971 mj(j)=zero
972 ENDDO
973 mj(nc)=one
974 IF (nc>10000) THEN
975 max_l=max_a
976 CALL imp_pcg1(
977 1 nc ,max_l ,iada ,jdia ,diag_a ,
978 2 lt_a ,mj ,ierr )
979 IF (i_chk>0.AND.ierr<0) nne = i
980 ELSE
981 max_l=1+(nc*(nc-1))/2
982 CALL imp_fsai(nc ,iada ,jdia ,diag_a ,lt_a ,
983 . max_l ,mj )
984 ENDIF
985C-----------------
986 diag_m(i)=mj(nc)
987 IF (diag_m(i)<em20) THEN
988 IF (nne==0.AND.i_chk==0) nne = i
989 diag_m(i)=abs(diag_m(i))
990 diag_m(i)=max(em20,diag_m(i))
991 ENDIF
992 DO k =1,nc-1
993 m=iadm(i)+k-1
994 lt_m(m)=mj(k)/diag_m(i)
995 ENDDO
996 IF (i_chk>0.AND.mj(nc)<em20) diag_m(i)=mj(nc)
997 ENDDO
998C
999 DEALLOCATE(iada,jdia)
1000 DEALLOCATE(jm)
1001 DEALLOCATE(diag_a,lt_a)
1002 DEALLOCATE(mj)
1003 k = 1
1004 IF (d_tol>zero)
1005 . CALL imp_kfiltr(k ,nddl ,iadm ,jdim ,diag_m ,
1006 . lt_m ,d_tol ,p_mach,diag_k)
1007C
1008 RETURN
sp_stat0
subroutine sp_stat0(il, iadk, jdik, nc, jm)
Definition imp_fsa_inv.F:35
get_subs0
subroutine get_subs0(nddl, iadk, jdik, diag_k, lt_k, nc, iada, jdia, diag_a, lt_a, jm, maxa)
Definition imp_fsa_inv.F:313
imp_kfiltr
subroutine imp_kfiltr(ndf, nd, iada, jdia, diag_a, lt_a, tol, e_ps, diag_k)
Definition imp_fsa_inv.F:1131
message_mod
Definition message_mod.F:1249
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:889
arret
subroutine arret(nn)
Definition arret.F:87

◆ imp_fsa_inv2hp()

subroutine imp_fsa_inv2hp ( integer nddl,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
diag_k,
lt_k,
integer, dimension(*) iadm,
integer, dimension(*) jdim,
diag_m,
lt_m,
integer maxc,
integer max_a,
integer nne,
integer idlft0,
integer idlft1,
integer max_d,
d_tol,
p_mach )

Definition at line 1809 of file imp_fsa_inv.F.

1814C-----------------------------------------------
1815C M o d u l e s
1816C-----------------------------------------------
1817 USE message_mod
1818C-----------------------------------------------
1819C I m p l i c i t T y p e s
1820C-----------------------------------------------
1821#include "implicit_f.inc"
1822C-----------------------------------------------
1823C C o m m o n B l o c k s
1824C-----------------------------------------------
1825#include "task_c.inc"
1826C-----------------------------------------------
1827C D u m m y A r g u m e n t s
1828C-----------------------------------------------
1829 INTEGER NDDL ,NNZ ,IADK(*),JDIK(*),MAXC ,MAX_A ,NNE,
1830 . IDLFT0 ,IDLFT1,MAX_D,IADM(*),JDIM(*)
1831C REAL
1832 my_real
1833 . diag_k(*), lt_k(*),diag_m(*), lt_m(*),d_tol ,p_mach
1834C-----------------------------------------------
1835C L o c a l V a r i a b l e s
1836C-----------------------------------------------
1837C--- M->A^-1 LT_M strictly lower in m.c.r.s. format
1838 INTEGER I,J,K,M,N,NC,MAX_L,IERR,I_CHK,IER1,
1839 . ITSK,F_DDL,L_DDL,N1
1840 my_real
1841 . diag_c(nddl-idlft1+1),lt_c(max_d+1)
1842 INTEGER OMP_GET_THREAD_NUM
1843 EXTERNAL omp_get_thread_num
1844C-----------------------------
1845 i_chk = nne
1846 nne = 0
1847 IF ((idlft0+1)>nddl) RETURN
1848C
1849C--------------copy la partie utile------
1850 k=iadk(idlft1+1)-1
1851!$OMP PARALLEL PRIVATE(ITSK,F_DDL,L_DDL,NC,MAX_L,N1,J,I)
1852 itsk = omp_get_thread_num()
1853 n1 = nddl-idlft1
1854 f_ddl = idlft1+1+itsk*n1/ nthread
1855 l_ddl = idlft1+(itsk+1)*n1/ nthread
1856 DO i=idlft1+1,nddl
1857 diag_c(i-idlft1) = diag_m(i)
1858 DO j=iadk(i),iadk(i+1)-1
1859 lt_c(j-k)=lt_m(j)
1860 ENDDO
1861 ENDDO
1862C----------------------
1863 CALL my_barrier
1864C---------------------
1865C Boucle parallele dynamique SMP
1866C
1867!$OMP DO SCHEDULE(DYNAMIC,1)
1868 DO i=idlft0+1,nddl
1869 CALL sp_dim(i ,iadm ,jdim ,nc ,max_a ,max_l )
1870 CALL fsa_solv(
1871 1 nddl ,nc ,iadk ,jdik ,diag_k ,
1872 2 lt_k ,diag_m,lt_m ,diag_c,lt_c ,
1873 3 max_l ,idlft0,idlft1,nne ,i_chk ,
1874 4 iadm ,jdim ,i )
1875 ENDDO
1876C
1877!$OMP END DO
1878!$OMP END PARALLEL
1879C
1880Citask0 IF (ITASK == 0 ) THEN
1881 k = idlft0+1
1882 IF (d_tol>zero)
1883 . CALL imp_kfiltr(k ,nddl ,iadm ,jdim ,diag_m ,
1884 . lt_m ,d_tol ,p_mach,diag_k)
1885Citask0 END IF
1886C
1887 RETURN
sp_dim
subroutine sp_dim(il, iadk, jdik, nc, max_a, max_l)
Definition imp_fsa_inv.F:1588
fsa_solv
subroutine fsa_solv(nddl, nc, iadk, jdik, diag_k, lt_k, diag_m, lt_m, diag_c, lt_c, max_a, idlft0, idlft1, nne, i_chk, iadm, jdim, i)
Definition imp_fsa_inv.F:1631
my_barrier
subroutine my_barrier
Definition machine.F:31

◆ imp_fsa_invh()

subroutine imp_fsa_invh ( integer nddl,
integer nnz,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
diag_k,
lt_k,
diag_m,
lt_m,
integer maxc,
integer max_a,
integer nne,
integer idlft0,
integer idlft1,
integer max_d,
integer itask )

Definition at line 1349 of file imp_fsa_inv.F.

1353C-----------------------------------------------
1354C M o d u l e s
1355C-----------------------------------------------
1356 USE message_mod
1357C-----------------------------------------------
1358C I m p l i c i t T y p e s
1359C-----------------------------------------------
1360#include "implicit_f.inc"
1361C-----------------------------------------------
1362C D u m m y A r g u m e n t s
1363C-----------------------------------------------
1364 INTEGER NDDL ,NNZ ,IADK(*),JDIK(*),MAXC ,MAX_A ,NNE,
1365 . IDLFT0 ,IDLFT1,MAX_D,ITASK
1366C REAL
1367 my_real
1368 . diag_k(*), lt_k(*),diag_m(*), lt_m(*)
1369C-----------------------------------------------
1370C L o c a l V a r i a b l e s
1371C-----------------------------------------------
1372C--- M->A^-1 LT_M strictly lower in m.c.r.s. format
1373 INTEGER I,J,K,M,N,NC,MAX_L,IERR,I_CHK,IER1,
1374 . JM(MAXC+1)
1375 my_real
1376 . diag_c(nddl-idlft1+1),lt_c(max_d+1)
1377 INTEGER, DIMENSION(:),ALLOCATABLE :: IADA,JDIA
1378 my_real, DIMENSION(:),ALLOCATABLE :: diag_a,lt_a,mj
1379C-----------------------------
1380 i_chk = nne
1381 nne = 0
1382 IF ((idlft0+1)>nddl) RETURN
1383C
1384 ALLOCATE(iada(maxc+1),diag_a(maxc),mj(maxc),stat=ier1)
1385 ALLOCATE(lt_a(max_a),jdia(max_a),stat=ierr)
1386
1387 IF ((ierr+ier1)/=0) THEN
1388 IF (itask == 0 ) THEN
1389 CALL ancmsg(msgid=19,anmode=aninfo,
1390 . c1='FOR IMPLICIT PRECONDITION')
1391 CALL arret(2)
1392 END IF !(ITASK == 0 ) THEN
1393 ENDIF
1394
1395C--------------copy la partie utile------
1396 k=iadk(idlft1+1)-1
1397 DO i=idlft1+1,nddl
1398 diag_c(i-idlft1) = diag_m(i)
1399 DO j=iadk(i),iadk(i+1)-1
1400 lt_c(j-k)=lt_m(j)
1401 ENDDO
1402 ENDDO
1403C----------------------
1404 CALL my_barrier
1405C---------------------
1406C
1407C Boucle parallele dynamique SMP
1408C
1409!$OMP DO SCHEDULE(DYNAMIC,1)
1410 DO i=idlft0+1,nddl
1411 CALL sp_stat0(i ,iadk ,jdik ,nc ,jm )
1412 CALL get_subsp(nddl ,iadk ,jdik ,diag_k ,lt_k ,
1413 . nc ,iada ,jdia ,diag_a ,lt_a ,
1414 . jm ,max_a ,idlft0,idlft1 ,diag_c,
1415 . lt_c ,diag_m ,lt_m )
1416 DO j=1,nc-1
1417 mj(j)=zero
1418 ENDDO
1419 mj(nc)=one
1420C
1421 IF (nc>10000) THEN
1422 max_l=max_a
1423 CALL imp_pcg1(
1424 1 nc ,max_l ,iada ,jdia ,diag_a ,
1425 2 lt_a ,mj ,ierr )
1426C
1427 IF (i_chk>0.AND.ierr<0) nne = i
1428 ELSE
1429C
1430 max_l=1+(nc*(nc-1))/2
1431 CALL imp_fsai(nc ,iada ,jdia ,diag_a ,lt_a ,
1432 . max_l ,mj )
1433C
1434 ENDIF
1435C------------filtrage----Diagonal est dans LT_M (last one)--
1436 diag_m(i)=mj(nc)
1437 IF (diag_m(i)<em20) THEN
1438 IF (nne==0.AND.i_chk==0) nne = i
1439 diag_m(i)=abs(diag_m(i))
1440 diag_m(i)=max(em20,diag_m(i))
1441 ENDIF
1442 DO k =1,nc-1
1443 m=iadk(i)+k-1
1444 lt_m(m)=mj(k)/diag_m(i)
1445 ENDDO
1446C
1447 IF (i_chk>0.AND.mj(nc)<em20) diag_m(i)=mj(nc)
1448 ENDDO
1449
1450!$OMP END DO
1451C
1452 DEALLOCATE(iada,diag_a,mj)
1453 DEALLOCATE(lt_a,jdia)
1454C
1455 RETURN

◆ imp_fsa_invh2()

subroutine imp_fsa_invh2 ( integer nddl,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
diag_k,
lt_k,
integer, dimension(*) iadm,
integer, dimension(*) jdim,
diag_m,
lt_m,
integer maxc,
integer max_a,
integer nne,
integer idlft0,
integer idlft1,
integer max_d,
d_tol,
p_mach,
integer itask )

Definition at line 1471 of file imp_fsa_inv.F.

1476C-----------------------------------------------
1477C M o d u l e s
1478C-----------------------------------------------
1479 USE message_mod
1480C-----------------------------------------------
1481C I m p l i c i t T y p e s
1482C-----------------------------------------------
1483#include "implicit_f.inc"
1484C-----------------------------------------------
1485C D u m m y A r g u m e n t s
1486C-----------------------------------------------
1487 INTEGER NDDL ,NNZ ,IADK(*),JDIK(*),MAXC ,MAX_A ,NNE,
1488 . IDLFT0 ,IDLFT1,MAX_D,IADM(*),JDIM(*),ITASK
1489C REAL
1490 my_real
1491 . diag_k(*), lt_k(*),diag_m(*), lt_m(*),d_tol ,p_mach
1492C-----------------------------------------------
1493C L o c a l V a r i a b l e s
1494C-----------------------------------------------
1495C--- M->A^-1 LT_M strictly lower in m.c.r.s. format
1496 INTEGER I,J,K,M,N,NC,MAX_L,IERR,I_CHK,IER1,
1497 . JM(MAXC+1)
1498 my_real
1499 . diag_c(nddl-idlft1+1),lt_c(max_d+1)
1500 INTEGER, DIMENSION(:),ALLOCATABLE :: IADA,JDIA
1501 my_real, DIMENSION(:),ALLOCATABLE :: diag_a,lt_a,mj
1502C-----------------------------
1503 i_chk = nne
1504 nne = 0
1505 IF ((idlft0+1)>nddl) RETURN
1506C
1507 ALLOCATE(iada(maxc+1),diag_a(maxc),mj(maxc),stat=ier1)
1508 ALLOCATE(lt_a(max_a),jdia(max_a),stat=ierr)
1509C--------
1510 IF ((ierr+ier1)/=0) THEN
1511 IF (itask == 0 ) THEN
1512 CALL ancmsg(msgid=19,anmode=aninfo,
1513 . c1='FOR IMPLICIT PRECONDITION')
1514 CALL arret(2)
1515 END IF !(ITASK == 0 ) THEN
1516 ENDIF
1517C--------------copy la partie utile------
1518 k=iadk(idlft1+1)-1
1519 DO i=idlft1+1,nddl
1520 diag_c(i-idlft1) = diag_m(i)
1521 DO j=iadk(i),iadk(i+1)-1
1522 lt_c(j-k)=lt_m(j)
1523 ENDDO
1524 ENDDO
1525C----------------------
1526 CALL my_barrier
1527C---------------------
1528C Boucle parallele dynamique SMP
1529C
1530!$OMP DO SCHEDULE(DYNAMIC,1)
1531 DO i=idlft0+1,nddl
1532 CALL sp_stat0(i ,iadm ,jdim ,nc ,jm )
1533 CALL get_subsp(nddl ,iadk ,jdik ,diag_k ,lt_k ,
1534 . nc ,iada ,jdia ,diag_a ,lt_a ,
1535 . jm ,max_a ,idlft0,idlft1 ,diag_c,
1536 . lt_c ,diag_m,lt_m )
1537 DO j=1,nc-1
1538 mj(j)=zero
1539 ENDDO
1540 mj(nc)=one
1541 IF (nc>10000) THEN
1542 max_l=max_a
1543 CALL imp_pcg1(
1544 1 nc ,max_l ,iada ,jdia ,diag_a ,
1545 2 lt_a ,mj ,ierr )
1546 IF (i_chk>0.AND.ierr<0) nne = i
1547 ELSE
1548 max_l=1+(nc*(nc-1))/2
1549 CALL imp_fsai(nc ,iada ,jdia ,diag_a ,lt_a ,
1550 . max_l ,mj )
1551 ENDIF
1552C------------Diagonal est dans LT_M (last one)--
1553 diag_m(i)=mj(nc)
1554 IF (diag_m(i)<em20) THEN
1555 IF (nne==0.AND.i_chk==0) nne = i
1556 diag_m(i)=abs(diag_m(i))
1557 diag_m(i)=max(em20,diag_m(i))
1558 ENDIF
1559 DO k =1,nc-1
1560 m=iadm(i)+k-1
1561 lt_m(m)=mj(k)/diag_m(i)
1562 ENDDO
1563C
1564 IF (i_chk>0.AND.mj(nc)<em20) diag_m(i)=mj(nc)
1565 ENDDO
1566C
1567!$OMP END DO
1568C
1569 DEALLOCATE(iada,diag_a,mj)
1570 DEALLOCATE(lt_a,jdia)
1571C
1572 IF (itask == 0 ) THEN
1573 k = idlft0+1
1574 IF (d_tol>zero)
1575 . CALL imp_kfiltr(k ,nddl ,iadm ,jdim ,diag_m ,
1576 . lt_m ,d_tol ,p_mach,diag_k)
1577 END IF
1578C
1579 RETURN

◆ imp_fsa_invhp()

subroutine imp_fsa_invhp ( integer nddl,
integer nnz,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
diag_k,
lt_k,
diag_m,
lt_m,
integer maxc,
integer max_a,
integer nne,
integer idlft0,
integer idlft1,
integer max_d )

Definition at line 1719 of file imp_fsa_inv.F.

1723C-----------------------------------------------
1724C M o d u l e s
1725C-----------------------------------------------
1726 USE message_mod
1727C-----------------------------------------------
1728C I m p l i c i t T y p e s
1729C-----------------------------------------------
1730#include "implicit_f.inc"
1731C-----------------------------------------------
1732C C o m m o n B l o c k s
1733C-----------------------------------------------
1734#include "task_c.inc"
1735C-----------------------------------------------
1736C D u m m y A r g u m e n t s
1737C-----------------------------------------------
1738 INTEGER NDDL ,NNZ ,IADK(*),JDIK(*),MAXC ,MAX_A ,NNE,
1739 . IDLFT0 ,IDLFT1,MAX_D
1740C REAL
1741 my_real
1742 . diag_k(*), lt_k(*),diag_m(*), lt_m(*)
1743C-----------------------------------------------
1744C L o c a l V a r i a b l e s
1745C-----------------------------------------------
1746C--- M->A^-1 LT_M strictly lower in m.c.r.s. format
1747 INTEGER I,J,K,M,N,NC,MAX_L,IERR,I_CHK,IER1,
1748 . ITSK,F_DDL,L_DDL,N1
1749 my_real
1750 . diag_c(nddl-idlft1+1),lt_c(max_d+1)
1751 INTEGER OMP_GET_THREAD_NUM
1752 EXTERNAL omp_get_thread_num
1753C-----------------------------
1754 i_chk = nne
1755 nne = 0
1756 IF ((idlft0+1)>nddl) RETURN
1757C
1758C--------------copy la partie utile------
1759 k=iadk(idlft1+1)-1
1760!$OMP PARALLEL PRIVATE(ITSK,F_DDL,L_DDL,NC,MAX_L,I,J,N1)
1761 itsk = omp_get_thread_num()
1762 n1 = nddl-idlft1
1763 f_ddl = idlft1+1+itsk*n1/ nthread
1764 l_ddl = idlft1+(itsk+1)*n1/ nthread
1765C
1766C----------------------
1767 CALL my_barrier
1768C---------------------
1769 DO i=f_ddl,l_ddl
1770 diag_c(i-idlft1) = diag_m(i)
1771 DO j=iadk(i),iadk(i+1)-1
1772 lt_c(j-k)=lt_m(j)
1773 ENDDO
1774 ENDDO
1775C----------------------
1776 CALL my_barrier
1777C---------------------
1778C
1779C Boucle parallele dynamique SMP
1780C
1781!$OMP DO SCHEDULE(DYNAMIC,1)
1782 DO i=idlft0+1,nddl
1783 CALL sp_dim(i ,iadk ,jdik ,nc ,max_a ,max_l )
1784 CALL fsa_solv(
1785 1 nddl ,nc ,iadk ,jdik ,diag_k ,
1786 2 lt_k ,diag_m,lt_m ,diag_c,lt_c ,
1787 3 max_l ,idlft0,idlft1,nne ,i_chk ,
1788 4 iadk ,jdik ,i )
1789 ENDDO
1790
1791!$OMP END DO
1792!$OMP END PARALLEL
1793C
1794 RETURN

◆ imp_fsa_invp()

subroutine imp_fsa_invp ( integer nddl,
integer nnz,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
diag_k,
lt_k,
diag_m,
lt_m,
integer maxc,
integer max_a,
integer nne,
integer idlft0,
integer idlft1,
integer max_d )

Definition at line 591 of file imp_fsa_inv.F.

595C-----------------------------------------------
596C M o d u l e s
597C-----------------------------------------------
598 USE message_mod
599C-----------------------------------------------
600C I m p l i c i t T y p e s
601C-----------------------------------------------
602#include "implicit_f.inc"
603C-----------------------------------------------
604C D u m m y A r g u m e n t s
605C-----------------------------------------------
606 INTEGER NDDL ,NNZ ,IADK(*),JDIK(*),MAXC ,MAX_A ,NNE,
607 . IDLFT0 ,IDLFT1,MAX_D
608C REAL
609 my_real
610 . diag_k(*), lt_k(*),diag_m(*), lt_m(*)
611C-----------------------------------------------
612C L o c a l V a r i a b l e s
613C-----------------------------------------------
614C--- M->A^-1 LT_M strictly lower in m.c.r.s. format
615 INTEGER I,J,K,M,N,NC,IADA(MAXC+1),JDIA(MAX_A),JM(MAXC+1)
616 INTEGER MAX_L,IERR,I_CHK
617 my_real
618 . diag_a(maxc),mj(maxc),
619 . diag_c(nddl-idlft1+1),lt_c(max_d+1)
620 my_real, DIMENSION(:),ALLOCATABLE :: lt_a
621C-----------------------------
622 ALLOCATE(lt_a(max_a),stat=ierr)
623 IF (ierr/=0) THEN
624 CALL ancmsg(msgid=19,anmode=aninfo,
625 . c1='FOR IMPLICIT PRECONDITION')
626 CALL arret(2)
627 ENDIF
628C--------------copy la partie utile------
629 i_chk = nne
630 nne = 0
631 k=iadk(idlft1+1)-1
632 DO i=idlft1+1,nddl
633 diag_c(i-idlft1) = diag_m(i)
634 DO j=iadk(i),iadk(i+1)-1
635 lt_c(j-k)=lt_m(j)
636 ENDDO
637 ENDDO
638 DO i=idlft0+1,nddl
639 CALL sp_stat0(i ,iadk ,jdik ,nc ,jm )
640 CALL get_subsp(nddl ,iadk ,jdik ,diag_k ,lt_k ,
641 . nc ,iada ,jdia ,diag_a ,lt_a ,
642 . jm ,max_a ,idlft0,idlft1 ,diag_c,
643 . lt_c ,diag_m ,lt_m )
644 DO j=1,nc-1
645 mj(j)=zero
646 ENDDO
647 mj(nc)=one
648 IF (nc>10000) THEN
649 max_l=max_a
650 CALL imp_pcg1(
651 1 nc ,max_l ,iada ,jdia ,diag_a ,
652 2 lt_a ,mj ,ierr )
653 IF (i_chk>0.AND.ierr<0) nne = i
654 ELSE
655 max_l=1+(nc*(nc-1))/2
656 CALL imp_fsai(nc ,iada ,jdia ,diag_a ,lt_a ,
657 . max_l ,mj )
658 ENDIF
659C------------filtrage----Diagonal est dans LT_M (last one)--
660 diag_m(i)=mj(nc)
661 IF (diag_m(i)<em20) THEN
662 IF (nne==0.AND.i_chk==0) nne = i
663 diag_m(i)=abs(diag_m(i))
664 diag_m(i)=max(em20,diag_m(i))
665 ENDIF
666 DO k =1,nc-1
667 m=iadk(i)+k-1
668 lt_m(m)=mj(k)/diag_m(i)
669 ENDDO
670 IF (i_chk>0.AND.mj(nc)<em20) diag_m(i)=mj(nc)
671 ENDDO
672 DEALLOCATE(lt_a)
673C
674 RETURN

◆ imp_fsa_invp2()

subroutine imp_fsa_invp2 ( integer nddl,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
diag_k,
lt_k,
integer, dimension(*) iadm,
integer, dimension(*) jdim,
diag_m,
lt_m,
integer maxc,
integer max_a,
integer nne,
integer idlft0,
integer idlft1,
integer max_d,
d_tol,
p_mach )

Definition at line 1023 of file imp_fsa_inv.F.

1028C-----------------------------------------------
1029C M o d u l e s
1030C-----------------------------------------------
1031 USE message_mod
1032C-----------------------------------------------
1033C I m p l i c i t T y p e s
1034C-----------------------------------------------
1035#include "implicit_f.inc"
1036C-----------------------------------------------
1037C D u m m y A r g u m e n t s
1038C-----------------------------------------------
1039 INTEGER NDDL ,NNZ ,IADK(*),JDIK(*),MAXC ,MAX_A ,NNE,
1040 . IDLFT0 ,IDLFT1,MAX_D,IADM(*),JDIM(*)
1041C REAL
1042 my_real
1043 . diag_k(*), lt_k(*),diag_m(*), lt_m(*),d_tol ,p_mach
1044C-----------------------------------------------
1045C L o c a l V a r i a b l e s
1046C-----------------------------------------------
1047C--- M->A^-1 LT_M strictly lower in m.c.r.s. format
1048 INTEGER I,J,K,M,N,NC,IADA(MAXC+1),JDIA(MAX_A),JM(MAXC+1)
1049 INTEGER MAX_L,IERR,I_CHK
1050 my_real
1051 . diag_a(maxc),mj(maxc),
1052 . diag_c(nddl-idlft1+1),lt_c(max_d+1)
1053 my_real, DIMENSION(:),ALLOCATABLE :: lt_a
1054C-----------------------------
1055 ALLOCATE(lt_a(max_a),stat=ierr)
1056 IF (ierr/=0) THEN
1057 CALL ancmsg(msgid=19,anmode=aninfo,
1058 . c1='FOR IMPLICIT PRECONDITION')
1059 CALL arret(2)
1060 ENDIF
1061C--------------copy la partie utile------
1062 i_chk = nne
1063 nne = 0
1064 k=iadk(idlft1+1)-1
1065 DO i=idlft1+1,nddl
1066 diag_c(i-idlft1) = diag_m(i)
1067 DO j=iadk(i),iadk(i+1)-1
1068 lt_c(j-k)=lt_m(j)
1069 ENDDO
1070 ENDDO
1071 DO i=idlft0+1,nddl
1072 CALL sp_stat0(i ,iadm ,jdim ,nc ,jm )
1073 CALL get_subsp(nddl ,iadk ,jdik ,diag_k ,lt_k ,
1074 . nc ,iada ,jdia ,diag_a ,lt_a ,
1075 . jm ,max_a ,idlft0,idlft1 ,diag_c,
1076 . lt_c ,diag_m,lt_m )
1077 DO j=1,nc-1
1078 mj(j)=zero
1079 ENDDO
1080 mj(nc)=one
1081 IF (nc>10000) THEN
1082 max_l=max_a
1083 CALL imp_pcg1(
1084 1 nc ,max_l ,iada ,jdia ,diag_a ,
1085 2 lt_a ,mj ,ierr )
1086 IF (i_chk>0.AND.ierr<0) nne = i
1087 ELSE
1088 max_l=1+(nc*(nc-1))/2
1089 CALL imp_fsai(nc ,iada ,jdia ,diag_a ,lt_a ,
1090 . max_l ,mj )
1091 ENDIF
1092C------------Diagonal est dans LT_M (last one)--
1093 diag_m(i)=mj(nc)
1094 IF (diag_m(i)<em20) THEN
1095 IF (nne==0.AND.i_chk==0) nne = i
1096 diag_m(i)=abs(diag_m(i))
1097 diag_m(i)=max(em20,diag_m(i))
1098 ENDIF
1099 DO k =1,nc-1
1100 m=iadm(i)+k-1
1101 lt_m(m)=mj(k)/diag_m(i)
1102 ENDDO
1103 IF (i_chk>0.AND.mj(nc)<em20) diag_m(i)=mj(nc)
1104 ENDDO
1105C
1106 DEALLOCATE(lt_a)
1107 k = idlft0+1
1108 IF (d_tol>zero)
1109 . CALL imp_kfiltr(k ,nddl ,iadm ,jdim ,diag_m ,
1110 . lt_m ,d_tol ,p_mach,diag_k)
1111C
1112 RETURN

◆ imp_fsai()

subroutine imp_fsai ( integer n,
integer, dimension(*) iada,
integer, dimension(*) jdia,
diag_a,
lt_a,
integer maxa,
mj )

Definition at line 265 of file imp_fsa_inv.F.

267C-----------------------------------------------
268C I m p l i c i t T y p e s
269C-----------------------------------------------
270#include "implicit_f.inc"
271C-----------------------------------------------
272C D u m m y A r g u m e n t s
273C-----------------------------------------------
274 INTEGER N ,IADA(*) ,JDIA(*),MAXA
275C REAL
276 my_real
277 . diag_a(*),lt_a(*),mj(*)
278C-----------------------------------------------
279C L o c a l V a r i a b l e s
280C-----------------------------------------------
281 INTEGER I,IADL(N+1),JDIL(MAXA),NNZL,NNE,IWA1(N)
282 my_real
283 . lt_l(maxa),wa1(n),diag_l(n)
284C-----------------------------------------------
285 CALL imp_fac_icj(
286 1 n ,maxa ,iada ,jdia ,diag_a ,
287 2 lt_a ,iadl ,jdil ,diag_l,lt_l ,
288 3 zero ,nnzl ,maxa ,iwa1 ,wa1 ,
289 4 nne )
290C
291#ifdef mumps5
292 CALL prec0_solv(n ,nnzl ,iadl ,jdil ,diag_l ,
293 1 lt_l ,mj ,wa1 )
294#endif
295 DO i=1,n
296 mj(i)=wa1(i)
297 ENDDO
298C--------------------------------------------
299 RETURN
imp_fac_icj
subroutine imp_fac_icj(nddl, nnz, iadk, jdik, diag_k, lt_k, iadm, jdim, diag_m, lt_m, psi, nnzm, max_l, isky, li, nne)
Definition imp_fac_ic.F:36
prec0_solv
subroutine prec0_solv(nddl, nnz, iadm, jdim, diag_m, lt_m, v, z)
Definition prec_solv.F:239

◆ imp_kfiltr()

subroutine imp_kfiltr ( integer ndf,
integer nd,
integer, dimension(*) iada,
integer, dimension(*) jdia,
diag_a,
lt_a,
tol,
e_ps,
diag_k )

Definition at line 1129 of file imp_fsa_inv.F.

1131C-----------------------------------------------
1132C M o d u l e s
1133C-----------------------------------------------
1134 USE message_mod
1135C-----------------------------------------------
1136C I m p l i c i t T y p e s
1137C-----------------------------------------------
1138#include "implicit_f.inc"
1139C-----------------------------------------------
1140C D u m m y A r g u m e n t s
1141C-----------------------------------------------
1142 INTEGER NDF,ND ,IADA(*) ,JDIA(*)
1143C REAL
1144 my_real
1145 . diag_a(*),lt_a(*),tol,e_ps,diag_k(*)
1146C-----------------------------------------------
1147C L o c a l V a r i a b l e s
1148C-----------------------------------------------
1149 INTEGER I,J,K,NZ,IERR,MNZ,INORM
1150 INTEGER, DIMENSION(:),ALLOCATABLE :: IADL,JDIL
1151 my_real
1152 . min_d,max_d,mtol,dd,taux
1153 my_real, DIMENSION(:),ALLOCATABLE :: lt_l
1154C-----------------------------
1155 print *,'D_tol,p_mach=',tol,e_ps
1156 nz = iada(nd+1)-iada(1)
1157 DO i = 1, ndf-1
1158 diag_a(i) = zero
1159 DO j = iada(i), iada(i+1)-1
1160 lt_a(j) = zero
1161 ENDDO
1162 iada(i+1) = 1
1163 ENDDO
1164 IF (nz>0.AND.tol>zero) THEN
1165 ALLOCATE(iadl(nd+1))
1166 ALLOCATE(jdil(nz),lt_l(nz),stat=ierr)
1167 IF (ierr/=0) THEN
1168 CALL ancmsg(msgid=19,anmode=aninfo,
1169 . c1='FOR IMPLICIT PRECONDITION')
1170 CALL arret(2)
1171 ENDIF
1172C-----------------------------------------------
1173 CALL cp_int(nd+1,iada,iadl)
1174 CALL cp_int(nz,jdia,jdil)
1175 CALL cp_real(nz,lt_a,lt_l)
1176 max_d = zero
1177 min_d = ep20
1178 DO i = ndf, nd
1179 max_d = max(max_d,diag_a(i))
1180 min_d = min(min_d,diag_a(i))
1181 ENDDO
1182 print *,'max_d,min_d=',max_d,min_d
1183c MTOL = TOL*MIN_D
1184c MTOL = MAX(E_PS,MTOL)
1185C------post-filtration------
1186 mnz = 0
1187 DO i = ndf, nd
1188 DO j = iadl(i), iadl(i+1)-1
1189 mtol = tol*min(diag_a(jdil(j)),diag_a(i))
1190 mtol = max(e_ps,mtol)
1191 IF (abs(lt_l(j))>mtol) THEN
1192 mnz = mnz + 1
1193 jdia(mnz) = jdil(j)
1194 lt_a(mnz) = lt_l(j)
1195 ENDIF
1196 ENDDO
1197 iada(i+1) = mnz + 1
1198 ENDDO
1199 DEALLOCATE(iadl,jdil)
1200 DEALLOCATE(lt_l)
1201 taux = one*mnz/nz
1202c print *,'mnz,nz=',mnz,nz,mtol
1203 print *,'filtrage factor=',taux
1204C------retrun from M normalized------
1205 ENDIF
1206 inorm = 0
1207 IF (inorm>zero) THEN
1208 DO i = ndf, nd
1209 diag_a(i) = diag_a(i)/diag_k(i)
1210 DO j = iada(i), iada(i+1)-1
1211 dd = sqrt(diag_k(i)/diag_k(jdia(j)))
1212 lt_a(j) = dd*lt_a(j)
1213 ENDDO
1214 ENDDO
1215 ENDIF
1216C--------------------------------------------
1217 RETURN
min
#define min(a, b)
Definition macros.h:20
cp_real
subroutine cp_real(n, x, xc)
Definition produt_v.F:871
cp_int
subroutine cp_int(n, x, xc)
Definition produt_v.F:916

◆ imp_pcg1()

subroutine imp_pcg1 ( integer nddl,
integer nnz,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
diag_k,
lt_k,
r,
integer isp )

Definition at line 690 of file imp_fsa_inv.F.

693C-----------------------------------------------
694C I m p l i c i t T y p e s
695C-----------------------------------------------
696#include "implicit_f.inc"
697C-----------------------------------------------
698C C o m m o n B l o c k s
699C-----------------------------------------------
700#include "impl2_c.inc"
701C-----------------------------------------------
702C D u m m y A r g u m e n t s
703C-----------------------------------------------
704C----------resol [K]{X}={F}---------
705 INTEGER NDDL ,NNZ ,IADK(*) ,JDIK(*)
706C REAL
707 my_real
708 . diag_k(*), lt_k(*) ,r(*)
709C-----------------------------------------------
710C L o c a l V a r i a b l e s
711C-----------------------------------------------
712 INTEGER I,J,IT,IP,NLIM,ND,IPRE,NNZM,ISTOP,ITOL,ISP
713 my_real
714 . s , r2, r02,alpha,beta,g0,g1,rr,tols,toln,tols2
715 my_real
716 . x(nddl) ,p(nddl) ,z(nddl) ,y(nddl),diag_m(nddl)
717 INTEGER CRIT_STOP
718 EXTERNAL crit_stop
719 my_real
720 . anorm2,xnorm2,l_a,l_b2,l_b,a_old,b_old,tmp,eps_m
721 my_real
722 . cs,dbar, delta, denom, kcond,snprod,qrnorm,
723 . gamma, gbar, gmax, gmin, epsln,lqnorm,diag,cgnorm,
724 . oldb, rhs1, rhs2,sn, zbar, zl ,oldb2,tnorm2,eps(4)
725C--------------INITIALISATION--------------------------
726 itol = 1
727 ipre = 2
728 nnzm = 0
729 nlim=max(nddl,2)
730 tols=sqrt(p_mach)
731 eps_m = p_mach
732 it=0
733 nd = nddl
734C-------------IT=0--------
735C------X(I)=ZERO--------
736 DO i=1,nddl
737 x(i) = zero
738 diag_m(i)=one/max(em20,diag_k(i))
739 ENDDO
740 CALL mav_lt(
741 1 nddl ,nnz ,iadk ,jdik ,diag_k,
742 2 lt_k ,x ,z )
743 DO i=1,nddl
744 r(i) = r(i)-z(i)
745 ENDDO
746 DO i=1,nddl
747 z(i) = r(i) *diag_m(i)
748 ENDDO
749 DO i=1,nddl
750 p(i) = z(i)
751 ENDDO
752 CALL produt_v0(nddl,r,z,g0)
753 CALL mav_lt(
754 1 nddl ,nnz ,iadk ,jdik ,diag_k,
755 2 lt_k ,p ,y )
756 CALL produt_v0(nddl,p,y,s)
757 alpha = g0/s
758 tols2=tols*tols
759 IF (itol==1) THEN
760 CALL produt_v0(nddl,r,r,r02)
761 r2 =r02
762 ELSEIF (itol==3) THEN
763C------ R2<TOL*TOL*ANORM2*XNORM2------
764 r02=abs(g0)
765 r2 =r02
766 l_a=one/alpha
767C L_B2=R02
768 tnorm2=l_a*l_a
769 anorm2=zero
770 xnorm2=zero
771 a_old=l_a
772 b_old=zero
773 oldb = sqrt(r02)
774 ELSEIF (itol==4) THEN
775 r02=alpha*alpha*abs(g0)
776 eps(1)=r02
777 r2=r02
778 ELSE
779 r02=abs(g0)
780 r2 =r02
781 ENDIF
782 IF (r02==zero) GOTO 200
783 toln=r02*tols2
784C-------pour etre coherent avec lanzos for linear
785 it=1
786 DO i=1,nddl
787 x(i) = x(i) + alpha*p(i)
788 r(i) = r(i) - alpha*y(i)
789 ENDDO
790 DO i=1,nddl
791 z(i) = r(i) *diag_m(i)
792 ENDDO
793 CALL produt_v0(nddl,r,z,g1)
794 beta=g1/g0
795 IF (itol==1) THEN
796 CALL produt_v0(nddl,r,r,r2)
797 ELSEIF (itol==3) THEN
798C------ R2<TOL*TOL*ANORM2*XNORM2------
799 r2=abs(g1)
800 l_b2=abs(beta)*a_old*a_old
801 l_b=sqrt(l_b2)
802 tnorm2=tnorm2+l_b2
803 b_old=beta
804C* INITIALIZE OTHER QUANTITIES.
805 gbar = l_a
806 dbar = l_b
807 rhs1 = oldb
808 rhs2 = zero
809 gmax = abs( l_a ) + eps_m
810 gmin = gmax
811 oldb2 = l_b2
812 oldb = l_b
813 ELSEIF (itol==4) THEN
814 r2=r02
815 ELSE
816 r2=abs(g1)
817 ENDIF
818 g0 = g1
819 IF (itol==3) toln=toln*anorm2
820 istop=crit_stop(it,r2,nlim,toln)
821 DO WHILE (istop==1)
822 DO i=1,nddl
823 p(i) = z(i) + beta*p(i)
824 ENDDO
825 CALL mav_lt(
826 1 nddl ,nnz ,iadk ,jdik ,diag_k,
827 2 lt_k ,p ,y )
828 CALL produt_v0(nddl,p,y,s)
829 alpha=g0/s
830 DO i=1,nddl
831 x(i) = x(i) + alpha*p(i)
832 r(i) = r(i) - alpha*y(i)
833 ENDDO
834 DO i=1,nddl
835 z(i) = r(i) *diag_m(i)
836 ENDDO
837 CALL produt_v0(nddl,r,z,g1)
838 beta=g1/g0
839 g0 = g1
840 IF (itol==1) THEN
841 CALL produt_v0(nddl,r,r,r2)
842 ELSEIF (itol==3) THEN
843 r2 =abs(g1)
844 s=one/alpha
845 l_a=s+b_old*a_old
846C----------L_B2 : beta(j-1)^2-A_OLD :1/alpha(j-1)-------
847 l_b2=abs(beta)*s*s
848 l_b=sqrt(l_b2)
849 a_old=s
850 b_old=beta
851 anorm2=tnorm2
852 tnorm2=tnorm2+l_a*l_a+oldb2+l_b2
853 gamma = sqrt( gbar*gbar + oldb2 )
854 cs = gbar / gamma
855 sn = oldb / gamma
856 delta = cs * dbar + sn * l_a
857 gbar = sn * dbar - cs * l_a
858 epsln = sn * l_b
859 dbar = - cs * l_b
860 zl = rhs1 / gamma
861 xnorm2 = xnorm2+zl*zl
862 gmax = max( gmax, gamma )
863 gmin = min( gmin, gamma )
864 rhs1 = rhs2 - delta * zl
865 rhs2 = - epsln * zl
866 toln=tols2*anorm2*xnorm2
867 oldb2 = l_b2
868 oldb = l_b
869 ELSEIF (itol==4) THEN
870 tmp=alpha*alpha*abs(g1)
871 IF (it>=nd) THEN
872 DO j=1,nd-1
873 eps(j)=eps(j+1)
874 ENDDO
875 eps(nd)=tmp
876 r2=zero
877 DO j=1,nd
878 r2=r2+eps(j)
879 ENDDO
880 ELSE
881 eps(it+1)=tmp
882 r2=r2+tmp
883 ENDIF
884 ELSE
885 r2 =abs(g1)
886 ENDIF
887 istop=crit_stop(it,r2,nlim,toln)
888 it = it +1
889 ENDDO
890 200 CONTINUE
891 IF(it>=nlim)THEN
892 isp =-1
893 ELSE
894 isp = 0
895 ENDIF
896C RR = SQRT(R2/R02)
897C WRITE(*,1002)IT,RR
898C--------X->R--------
899 DO i=1,nddl
900 r(i) = x(i)
901 ENDDO
902C--------------------------------------------
903 1002 FORMAT(3x,'TOTAL C.G. ITERATION=',i8,5x,
904 . ' RELATIVE RESIDUAL NORM=',e11.4)
905 1003 FORMAT(5x,
906 . '---WARNING : THE ITERATION LIMIT NUMBER WAS REACHED',
907 . 1x,'IN PRECONDITIONER')
908 RETURN
alpha
#define alpha
Definition eval.h:35
crit_stop
integer function crit_stop(it, r2, it_max, tol)
Definition imp_pcg.F:32
produt_v0
subroutine produt_v0(nddl, x, y, r)
Definition produt_v.F:944
mav_lt
subroutine mav_lt(nddl, nnz, iadl, jdil, diag_k, lt_k, v, w)
Definition produt_v.F:340

◆ ind_lt2ln()

subroutine ind_lt2ln ( integer nddl,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
lt_k,
integer maxl )

Definition at line 1284 of file imp_fsa_inv.F.

1285C-------------
1286C-----------------------------------------------
1287C I m p l i c i t T y p e s
1288C-----------------------------------------------
1289#include "implicit_f.inc"
1290C-----------------------------------------------
1291C D u m m y A r g u m e n t s
1292C-----------------------------------------------
1293 INTEGER NDDL, IADK(*),JDIK(*),MAXL
1294 my_real
1295 . lt_k(*)
1296C REAL
1297C-----------------------------------------------
1298C L o c a l V a r i a b l e s
1299C-----------------------------------------------
1300 INTEGER IADM(NDDL+1),JDIM(MAXL),ICOL(NDDL)
1301 INTEGER I,JD,J,K,N,NM
1302 my_real
1303 . lt_m(maxl)
1304C-----------------------------------------------
1305 CALL cp_int(nddl+1,iadk,iadm)
1306 CALL cp_int(maxl,jdik,jdim)
1307 CALL cp_real(maxl,lt_k,lt_m)
1308C
1309 DO i = 1, nddl
1310 icol(i) = 0
1311 DO j = iadm(i),iadm(i+1)-1
1312 jd = jdim(j)
1313 icol(jd) = icol(jd) + 1
1314 ENDDO
1315 ENDDO
1316C
1317 iadk(1) = 1
1318 DO i = 1,nddl
1319 iadk(i+1) = iadk(i)+icol(i)
1320 ENDDO
1321C
1322 DO i = 1,nddl
1323 icol(i) = 0
1324 DO j=iadm(i),iadm(i+1)-1
1325 jd = jdim(j)
1326 k = iadk(jd) + icol(jd)
1327 jdik(k) = i
1328 lt_k(k) = lt_m(j)
1329 icol(jd) = icol(jd) + 1
1330 ENDDO
1331 ENDDO
1332C--------------------------------------------
1333 RETURN

◆ intab0()

integer function intab0 ( integer nic,
integer, dimension(*) ic,
integer n )

Definition at line 508 of file imp_fsa_inv.F.

509C----6---------------------------------------------------------------7---------8
510C I m p l i c i t T y p e s
511C-----------------------------------------------
512#include "implicit_f.inc"
513C-----------------------------------------------------------------
514C D u m m y A r g u m e n t s
515C-----------------------------------------------
516 INTEGER N ,NIC,IC(*)
517C-----------------------------------------------
518C L o c a l V a r i a b l e s
519C-----------------------------------------------
520 INTEGER I,J
521C----6-----IC est deja en ordre croissante---------------------------7---------8
522 intab0=0
523 IF (n<ic(1).OR.n>ic(nic)) RETURN
524 IF (n<nic/2) THEN
525 DO i =1,nic
526 IF (n==ic(i)) THEN
527 intab0=i
528 RETURN
529 ENDIF
530 ENDDO
531 ELSE
532 DO i =nic,1,-1
533 IF (n==ic(i)) THEN
534 intab0=i
535 RETURN
536 ENDIF
537 ENDDO
538 ENDIF
539C
540 RETURN

◆ intab2()

integer function intab2 ( integer nic1,
integer, dimension(*) ic1,
integer nic2,
integer, dimension(*) ic2 )

Definition at line 550 of file imp_fsa_inv.F.

551C----6---------------------------------------------------------------7---------8
552C I m p l i c i t T y p e s
553C-----------------------------------------------
554#include "implicit_f.inc"
555C-----------------------------------------------------------------
556C D u m m y A r g u m e n t s
557C-----------------------------------------------
558 INTEGER NIC1,IC1(*),NIC2,IC2(*)
559C-----------------------------------------------
560C External function
561C-----------------------------------------------
562 INTEGER INTAB0
563 EXTERNAL intab0
564C-----------------------------------------------
565C L o c a l V a r i a b l e s
566C-----------------------------------------------
567 INTEGER I,J
568C----6-----ICi est deja en ordre croissante--return indice dans IC1--7---------8
569 intab2=0
570 IF (ic1(nic1)<ic2(1).OR.ic2(nic2)<ic1(1)) RETURN
571C IF (NIC1>NIC2) THEN
572 DO i =1,nic2
573 intab2=intab0(nic1,ic1,ic2(i))
574 IF (intab2>0) RETURN
575 ENDDO
576 RETURN
intab2
integer function intab2(nic1, ic1, nic2, ic2)
Definition imp_fsa_inv.F:551

◆ sp_a2()

subroutine sp_a2 ( integer nddl,
integer, dimension(*) nc,
integer, dimension(maxc,*) jm,
integer maxc,
integer ifsai )

Definition at line 186 of file imp_fsa_inv.F.

187C-----------------------------------------------
188C I m p l i c i t T y p e s
189C-----------------------------------------------
190#include "implicit_f.inc"
191C-----------------------------------------------
192C D u m m y A r g u m e n t s
193C-----------------------------------------------
194 INTEGER NDDL,NC(*),MAXC,IFSAI
195 INTEGER JM(MAXC,*)
196C-----------------------------------------------
197C External function
198C-----------------------------------------------
199 INTEGER INTAB2
200 EXTERNAL intab2
201C REAL
202C-----------------------------------------------
203C L o c a l V a r i a b l e s
204C-----------------------------------------------
205 INTEGER I,J,NN(NDDL),JN(MAXC,NDDL)
206C-----------------------------------------------
207 DO i=1,nddl
208 nn(i)=nc(i)
209 nc(i)=0
210 DO j=1,nn(i)
211 jn(j,i)=jm(j,i)
212 ENDDO
213 ENDDO
214 IF (ifsai==1) THEN
215 DO i=1,nddl
216 nc(i) = nc(i)+1
217 jm(nc(i),i)=i
218 DO j=i+1,nddl
219 IF(intab2(nn(i),jn(1,i),nn(j),jn(1,j))>0) THEN
220 nc(j) = nc(j)+1
221 jm(nc(j),j)=i
222 IF (nc(j)>maxc) THEN
223 WRITE(*,*)'N>MAXB',nc(j),maxc,j
224 CALL arret(2)
225 ENDIF
226 ENDIF
227 ENDDO
228 ENDDO
229 ELSE
230 DO i=1,nddl
231 nc(i) = nc(i)+1
232 jm(nc(i),i)=i
233 DO j=i+1,nddl
234 IF(intab2(nn(i),jn(1,i),nn(j),jn(1,j))>0) THEN
235 nc(i) = nc(i)+1
236 jm(nc(i),i)=j
237 nc(j) = nc(j)+1
238 jm(nc(j),j)=i
239 IF (nc(i)>maxc) THEN
240 WRITE(*,*)'N>MAXB',nc(i),maxc,i
241 CALL arret(2)
242 ENDIF
243 ENDIF
244 ENDDO
245 ENDDO
246 ENDIF
247C--------------------------------------------
248 RETURN

◆ sp_dim()

subroutine sp_dim ( integer il,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
integer nc,
integer max_a,
integer max_l )

Definition at line 1587 of file imp_fsa_inv.F.

1588C-----------------------------------------------
1589C I m p l i c i t T y p e s
1590C-----------------------------------------------
1591#include "implicit_f.inc"
1592C-----------------------------------------------
1593C D u m m y A r g u m e n t s
1594C-----------------------------------------------
1595 INTEGER IL, IADK(*) ,JDIK(*),NC,MAX_A ,MAX_L
1596C REAL
1597C-----------------------------------------------
1598C L o c a l V a r i a b l e s
1599C-----------------------------------------------
1600 INTEGER I,J,K
1601C-----------------------------------------------
1602 nc=0
1603 DO k =iadk(il),iadk(il+1)-1
1604 nc=nc+1
1605 ENDDO
1606 nc=nc+1
1607C------MAX_L<- MAX_A
1608 IF (nc <= 10000) THEN
1609 max_l = 1+(nc*(nc-1))/2
1610 ELSE
1611 max_l = max_a
1612 END IF
1613C--------------------------------------------
1614 RETURN

◆ sp_stat0()

subroutine sp_stat0 ( integer il,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
integer nc,
integer, dimension(*) jm )

Definition at line 34 of file imp_fsa_inv.F.

35C-----------------------------------------------
36C I m p l i c i t T y p e s
37C-----------------------------------------------
38#include "implicit_f.inc"
39C-----------------------------------------------
40C D u m m y A r g u m e n t s
41C-----------------------------------------------
42 INTEGER IL, IADK(*) ,JDIK(*),NC,JM(*)
43C REAL
44C-----------------------------------------------
45C L o c a l V a r i a b l e s
46C-----------------------------------------------
47 INTEGER I,J,K
48C-----------------------------------------------
49 nc=0
50 DO k =iadk(il),iadk(il+1)-1
51 nc=nc+1
52 jm(nc)=jdik(k)
53 ENDDO
54 nc=nc+1
55 jm(nc)=il
56C--------------------------------------------
57 RETURN

◆ sp_static()

subroutine sp_static ( integer nddl,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
diag_k,
lt_k,
integer, dimension(*) iadm,
integer, dimension(*) jdim,
integer nnzm,
integer, dimension(*) nc,
integer, dimension(maxc,*) jm,
integer maxc,
psi,
integer ip )

Definition at line 67 of file imp_fsa_inv.F.

70C-----------------------------------------------
71C I m p l i c i t T y p e s
72C-----------------------------------------------
73#include "implicit_f.inc"
74C-----------------------------------------------
75C D u m m y A r g u m e n t s
76C-----------------------------------------------
77C--IP:0 standard; unpaire:avec pre-filtre; 2,3 level 2; >4 fsai(ip-4 : 6,7:level 2)
78 INTEGER NDDL ,MAXC,IADK(*) ,JDIK(*)
79 INTEGER NNZM,IADM(*) ,JDIM(*),NC(*),JM(MAXC,*),IP
80C REAL
81 my_real
82 . lt_k(*),diag_k(*),psi
83C-----------------------------------------------
84C L o c a l V a r i a b l e s
85C-----------------------------------------------
86 INTEGER I,J,N,K,I1,IFSAI,IOPT
87 my_real
88 . psr
89C-----------------------------------------------
90 IF (ip>=4) THEN
91 ifsai=1
92 iopt=ip-4
93 ELSE
94 ifsai=0
95 iopt=ip
96 ENDIF
97C------define sparse static pattern:----
98 nnzm = 0
99 iadm(1)=1
100C-------symmetry firstly---
101 IF (mod(iopt,2)>0) THEN
102C-------pre-filtrage----
103 DO i=1,nddl
104 DO k =iadk(i),iadk(i+1)-1
105 j=jdik(k)
106 psr = psi*sqrt(diag_k(i)*diag_k(j))
107 IF (abs(lt_k(k))>=psr) THEN
108 nnzm = nnzm+1
109 jdim(nnzm)=j
110 ENDIF
111 ENDDO
112 iadm(i+1)=nnzm+1
113 ENDDO
114 ELSE
115 DO i=2,nddl+1
116 iadm(i)=iadk(i)
117 ENDDO
118 nnzm= iadk(nddl+1)-1
119 DO i=1,nnzm
120 jdim(i)=jdik(i)
121 ENDDO
122 ENDIF
123C
124 DO i=1,nddl
125 nc(i)=0
126 ENDDO
127C
128 IF (iopt>1) THEN
129 DO i=1,nddl
130C------------avec diag----
131 nc(i) = nc(i)+1
132 jm(nc(i),i)=i
133 DO k =iadm(i),iadm(i+1)-1
134 j=jdim(k)
135 nc(j) = nc(j)+1
136 jm(nc(j),j)=i
137 nc(i) = nc(i)+1
138 jm(nc(i),i)=j
139 ENDDO
140 ENDDO
141 CALL sp_a2(nddl,nc,jm,maxc,ifsai)
142 ELSE
143 IF (ifsai==1) THEN
144 DO i=1,nddl
145 nc(i) = nc(i)+1
146 jm(nc(i),i)=i
147 DO k =iadm(i),iadm(i+1)-1
148 j=jdim(k)
149 nc(j) = nc(j)+1
150 jm(nc(j),j)=i
151 ENDDO
152 IF (nc(i)>maxc) THEN
153 WRITE(*,*)'N>MAXB',nc(i),maxc,i
154 CALL arret(2)
155 ENDIF
156 ENDDO
157 ELSE
158 DO i=1,nddl
159 nc(i) = nc(i)+1
160 jm(nc(i),i)=i
161 DO k =iadm(i),iadm(i+1)-1
162 j=jdim(k)
163 nc(j) = nc(j)+1
164 jm(nc(j),j)=i
165 nc(i) = nc(i)+1
166 jm(nc(i),i)=j
167 ENDDO
168 IF (nc(i)>maxc) THEN
169 WRITE(*,*)'N>MAXB',nc(i),maxc,i
170 CALL arret(2)
171 ENDIF
172 ENDDO
173 ENDIF
174 ENDIF
175C--------------------------------------------
176 RETURN
sp_a2
subroutine sp_a2(nddl, nc, jm, maxc, ifsai)
Definition imp_fsa_inv.F:187