1 : C DIAGNE SOURCE PV 12/12/04 21:15:06 7586 2 : SUBROUTINE DIAGNE 3 : ************************************************************************ 4 : * 5 : * D I A G N E 6 : * ----------- 7 : * 8 : * SOUS-PROGRAMME ASSOCIE A L'OPERATEUR "DIAGNEG" 9 : * 10 : * FONCTION: 11 : * --------- 12 : * DONNER LE NOMBRE DE TERMES DIAGONAUX NEGATIFS DE LA MATICE 13 : * DIAGONALE "D" D'UNE 'RIGIDITE' DECOMPOSEE EN L.D.LT 14 : * 15 : * PHRASE D'APPEL (EN GIBIANE): 16 : * ---------------------------- 17 : * NOMBRE = DIAGNEG RIGID ; 18 : * 19 : * ARGUMENTS (EN GIBIANE): 20 : * ----------------------- 21 : * RIGID 'RIGIDITE' MATRICE DE RIGIDITE. 22 : * NOMBRE 'ENTIER ' NOMBRE DE TERMES DIAGONAUX NEGATIFS. 23 : * 24 : * DICTIONNAIRE DES VARIABLES: (ORDRE ALPHABETIQUE) 25 : * --------------------------- 26 : * IPRIGI ENTIER POINTEUR SUR "RIGID". 27 : * INFER0 ENTIER CONTENU DE "NOMBRE". 28 : * 29 : * SOUS-PROGRAMMES APPELES: LIRE, ECRIRE, DIAGN1. 30 : * 31 : * CREATION: PASCAL MANIGOT, 8 OCTOBRE 1984 32 : * MODIF : - correction bug si on utilise DIAG puis RESO (BP, 12/05/2011) 33 : * en utilisant syntaxe de RESOU 34 : * - idem mais en gardant la syntaxe d'origine (BP, 12/09/2011) 35 : * 36 : * LANGAGE: FORTRAN77 + EXTENSION: CARACTERES MIS DANS DES ENTIERS 37 : * 38 : ************************************************************************ 39 : * 40 : IMPLICIT INTEGER(I-N) 41 : -INC CCOPTIO 42 : -INC SMRIGID 43 : -INC SMELEME 44 : * 45 : * 46 : * 47 : ICODE = 1 47 : CALL LIROBJ ('RIGIDITE',IPRIGI,ICODE,IRETOU) 48 : if (ierr.ne.0) return 49 : 50 : c c bp: ancienne methode -----------------------------------------------* 50 : c call dbblx(iprigi,lagdu) 51 : c IF(IERR .NE. 0) RETURN 52 : 53 : c c bp: nouvelle methode (basee sur RESOU) -----------------------------* 54 : c IPRIG0=IPRIGI 55 : c ipoiri=IPRIGI 56 : c * verification pas de blocage en double 56 : c call verlag(ipoiri) 57 : c if(ierr.ne.0) return 58 : c * y a t il des matrices de relations non unilaterales 59 : c ipoir0 = ipoiri 60 : c mrigid=ipoiri 61 : c segact mrigid 62 : c nrige= irigel(/1) 63 : c idepe=0 64 : c nbr = irigel(/2) 65 : c do 1000 irig = 1,nbr 66 : c meleme=irigel(1,irig) 67 : c segact meleme 68 : c if((irigel(6,irig).eq.0.or.nounil.eq.1).and.itypel.eq.22) 69 : c & idepe=idepe+1 70 : c if(irigel(6,irig).ne.0) iunil=1 71 : c segdes meleme 72 : c 1000 continue 73 : c * idepe=0 74 : c lagdua=0 75 : c 76 : c if (idepe.ne.0) then 77 : c 78 : c C on va separer les raideurs 79 : c if (jrcond.eq.0) then 79 : c call separm(mrigid,ri1,ri2,nounil,lagdua) 80 : c segact mrigid*mod 81 : c jrelim=ri1 82 : c jrgard=ri2 83 : c imlag=lagdua 83 : c call fusrig(ri1,ri2,ipoir0) 84 : c jrtot=ipoir0 85 : c else 86 : c ri1=jrelim 87 : c ri2=jrgard 88 : c ipoir0=jrtot 89 : c lagdua=imlag 90 : c ipt1=lagdua 91 : c if(ipt1.ne.0) segact ipt1 92 : c endif 93 : c iri1s=ri1 94 : c iri2s=ri2 95 : c C 96 : c 1010 continue 97 : c C 98 : c * mrigid matrice complete 99 : c * ri1 dependance 100 : c * ri2 les autres matrices 101 : c * ri6 matrice de transfert 102 : c * ri3 matrice reduite 103 : c * ri5 matrice de transfert transposee 104 : c C 105 : c C on va proceder a la condensation rigidite 106 : c if (jrcond.eq.0) then 106 : c CALL DEPEN3(RI1,RI6) 106 : c call scnd2 (ri2,ri6,ri3) 107 : c segact ri3 108 : c if (ierr.ne.0) then 109 : c segsup ri1,ri2,ri6 110 : c return 111 : c endif 112 : c segact mrigid*mod 113 : c jrcond=ri3 114 : c JRDEPP=RI6 115 : c C dualisation de la (les) matrice(s) de dependance 115 : c call dual00(ri6,ri5) 116 : c jrdepd=ri5 117 : c ipoiri = ri3 118 : c else 119 : c ipoiri= jrcond 120 : c RI6 = JRDEPP 121 : c ri5 = jrdepd 122 : c endif 123 : c * test si ri3 est vide 124 : c ri3=jrcond 125 : c segact ri3 126 : c if(ri3.irigel(/2).eq.0) imtvid=1 127 : c C 128 : c segdes ri1,ri2,mrigid 129 : c 130 : c noid = 1 131 : c endif 132 : c 133 : c * bp : on fournit ipoiri = jrcond de IPRIG0 a DIAGN1 qui fait le reste 134 : c IPRIGI=ipoiri 135 : 136 : c bp: ancienne methode corrigée --------------------------------------* 137 : * on travaille desormais sur une copie locale du mrigid 138 : mrigid=IPRIGI 139 : segini,RI1=mrigid 140 : IPRIGI=RI1 141 : segact ri1 142 : imlagl = ri1.imlag 142 : if (imlagl.eq.0) call dbblx(iprigi,lagdu) 143 : IF(IERR .NE. 0) RETURN 144 : 145 : c bp: fin de la distinction entre methode ----------------------------* 146 : * 146 : CALL DIAGN1 (IPRIGI,INFER0) 147 : IF(IERR.NE.0) RETURN 148 : * 148 : CALL ECRENT (INFER0) 149 : * 150 : * destruction objets "locaux" (version ancienne methode corrigée) 151 : segsup,RI1 152 : ipt1=lagdu 153 : if(imlagl.eq.0.and.ipt1.ne.0) segsup,ipt1 154 : * 155 : END 156 : 157 : 158 : 159 : 160 :
© Cast3M 2003 - All rights reserved.
Disclaimer