1 : C LANCZ3 SOURCE PV 11/02/18 21:15:04 6875 2 : SUBROUTINE LANCZ3 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8 (A-H,O-Z) 5 : ************************************************************************ 6 : * 7 : * L A N C Z 3 8 : * ----------- 9 : * 10 : * FONCTION: 11 : * --------- 12 : * 13 : * CREATION DES OBJETS 'RIGIDITE' DU PROBLEME REDUIT TRIDIAGONAL 14 : * SYMETRIQUE: 15 : * 16 : * | A1 B1 0 0 0 | | S1 0 0 0 0 | 17 : * | B1 A2 B2 0 0 | | 0 S2 0 0 0 | 18 : * "TRID" = | 0 B2 A3 B3 0 | "DIAG" = | 0 0 S3 0 0 | 19 : * | 0 0 B3 A4 B4 | | 0 0 0 S4 0 | 20 : * | 0 0 0 B4 A5 | | 0 0 0 0 S5 | 21 : * 22 : * (EXEMPLE D'UN PROBLEME REDUIT A LA TAILLE 5) 23 : * 24 : * MODE D'APPEL: 25 : * ------------- 26 : * 26 : * CALL LANCZ3 27 : * 28 : * PARAMETRES: (E)=ENTREE (S)=SORTIE 29 : * ----------- 30 : * 31 : * +A1 REEL DP (E) 32 : * +B1 REEL DP (E) 33 : * +IPV1 ENTIER (E) 34 : * +NUMV ENTIER (E) 35 : * +S1 REEL DP (E) 36 : * +IPDIAG ENTIER E/S 37 : * +IPTRID ENTIER E/S 38 : * +IPTABV ENTIER E/S 39 : * 40 : * + = PARAMETRE PASSE PAR L'UN DES COMMUNS "CLANCZ" ET "CSIMUL" 41 : * (VOIR LES DEFINITIONS DETAILLEES DANS LE SOUS-PROGRAMME "SIMUL0"). 42 : * 43 : * LEXIQUE: (ORDRE ALPHABETIQUE) 44 : * -------- 45 : * 46 : * A0 REEL DP VALEUR DE "A1" A L'ITERATION PRECEDENTE. 47 : * IPCOMP ENTIER POINTEUR DU 'LISTMOTS' CONTENANT LE NOM DES 48 : * COMPOSANTES DES POINTS DES 'RIGIDITES' CREEES 49 : * (VOIR LE SOUS-PROGRAMME "MANRIG"). 50 : * IPLM1 ENTIER POINTEUR DU SUPPORT GEOMETRIQUE (OBJET 51 : * 'MAILLAGE') D'UNE PARTIE DE LA 'RIGIDITE' "DIAG" 52 : * IPLM2 ENTIER POINTEUR DU SUPPORT GEOMETRIQUE (OBJET 53 : * 'MAILLAGE') D'UNE PARTIE DE LA 'RIGIDITE' "TRID" 54 : * IPOIN0 ENTIER POINT CREE A L'ITERATION PRECEDENTE. 55 : * IPOIN1 ENTIER POINT CREE POUR DEFINIR DES SUPPORTS 56 : * GEOMETRIQUES AUX 'RIGIDITES' CREEES. 57 : * IPS ENTIER POINTEUR D'UN 'LISTREEL' CONTENANT UNE MATRICE 58 : * ELEMENTAIRE DE LA 'RIGIDITE' "DIAG". 59 : * IP0BA ENTIER POINTEUR D'UN 'LISTREEL' CONTENANT UNE MATRICE 60 : * ELEMENTAIRE DE LA 'RIGIDITE' "TRID". 61 : * LISPO1 ENTIER CONTIENT LE OU LES POINTS UTILE(S) POUR CREER 62 : * UN SUPPORT GEOMETRIQUE. 63 : * 64 : * MODE DE FONCTIONNEMENT: 65 : * ----------------------- 66 : * 67 : * "TRID" ET "DIAG" SONT FAITES PAR AJOUT D'UNE PETITE 'RIGIDITE' A 68 : * CHAQUE CREATION D'UN NOUVEAU VECTEUR DE LANCZOS. CES 'RIGIDITES' 69 : * SONT DE LA FORME (POUR LE VECTEUR NUMERO "I"): 70 : * 71 : * POUR "DIAG": |S(I)| (MATRICE 1X1) 72 : * 73 : * POUR "TRID": | 0 B(I)| SAUF LA 1ERE FOIS: |A(1) B(2)| 74 : * |B(I) A(I)| |B(2) A(2)| 75 : * 76 : * PAR RAPPORT AUX NOTATIONS DU PARAGRAPHE "FONCTION", ON A: 77 : * A(1) = A1, A(2) = A2, ... 78 : * S(1) = S1, S(2) = S2, ... 79 : * MAIS: B(2) = B1, B(3) = B2, ... 80 : * 81 : * SOUS-PROGRAMMES APPELES: 82 : * ------------------------ 83 : * 84 : * CREPO1, DTRIGI, FUSRIG, INSER0, MANELM, MANRIG, PRRIGI. 85 : * 86 : * AUTEUR, DATE DE CREATION: 87 : * ------------------------- 88 : * 89 : * PASCAL MANIGOT 25 AVRIL 1985 90 : * 91 : * LANGAGE: 92 : * -------- 93 : * 94 : * ESOPE + FORTRAN77 + EXTENSION: CARACTERES MIS DANS DES ENTIERS. 95 : * 96 : ************************************************************************ 97 : * 98 : -INC CCOPTIO 99 : -INC SMLREEL 100 : -INC SMCOORD 101 : -INC SMTABLE 102 : -INC SMELEME 103 : -INC SMRIGID 104 : -INC SMLENTI 105 : * 106 : * REGOUPEMENT DE RENSEIGNEMENTS POUR LES SOUS-PROGRAMMES "LANCZ.": 107 : COMMON/CLANCZ/ A1,B1,S0,S1,NOMBRV,NUMV,NUMV1,IPV0,IPV1 108 : & ,IPMV1,IPVV,IPKVV,IPVTKV,IPLMOX,IPLMOY, 109 : & IVEV1, IVEMV1,ivev0,ipla,iplb,iplc 110 : * 111 : * REGROUPEMENT D'INFORMATIONS POUR LES SOUS-PROGRAMMES "SIMUL.": 112 : COMMON/CSIMUL/ W2SHIF,IPTTA,IPTTB,IPTABV,IPTRID,IPDIAG,iptvev, 113 : $ mvecri 114 : * 115 : * 116 : nbno=xcoor(/1)/(idim+1) 117 : nbpts=nbno+numv 118 : segadj mcoord 119 : * 120 : mlree1=ipla 121 : mlree2=iplb 122 : mlree3=iplc 123 : mlent1=ipvv 124 : mlent3=ivev1 125 : segact mlent1,mlent3 126 : M=numv 127 : segini mtable,mtab1 128 : iptvev=mtab1 129 : iptabv=mtable 130 : mlotab=m 131 : * write(6,18)'ipla ',(iou, mlree1.prog(iou),iou=1,mlree1.prog(/1)) 132 : * write(6,18)'iplb ',(iou, mlree2.prog(iou),iou=1,mlree1.prog(/1)) 133 : * write(6,18)'iplc ',(iou, mlree3.prog(iou),iou=1,mlree1.prog(/1)) 134 : * 18 format( A6,(I6,2X, f15.8,3X,I6,2X,f15.8)) 135 : do iou=1,m 136 : mtabti(iou)='POINT' 137 : mtabii(iou)=nbno+iou 138 : * write(6,*) iou, 'ieme point cree numero ',nbno+iou 139 : mtabtv(iou)='CHPOINT' 140 : mtabiv(iou)=mlent1.lect(iou) 141 : mtab1.mtabiv(iou)=mlent3.lect(iou) 142 : enddo 143 : 144 : * on commence par la matrice "ipdiag" 145 : nbelem=numv 146 : nbnn=1 147 : nbsous=0 148 : nbref=0 149 : segini meleme 150 : itypel=1 151 : nrigel=1 152 : segini mrigid 153 : coerig(1)=1.d0 154 : mtymat='MASSE' 155 : nligrp=1 156 : nligrd=1 157 : segini descr 158 : lisinc(1)='ALFA' 159 : lisdua(1)='FALF' 160 : noelep(1)=1 161 : noeled(1)=1 162 : segdes descr 163 : irigel(1,1)=meleme 164 : irigel(3,1)=descr 165 : nelrig=numv 166 : segini xmatri 167 : irigel(4,1)=xmatri 168 : irigel(5,1)=nifour 169 : do irig=1,numv 170 : num(1,irig)=nbno+irig 171 : re(1,1,irig)=mlree3.prog(irig) 172 : enddo 173 : ipdiag=mrigid 174 : * on continue par matrice tridiagonale "iptrid" 175 : nbelem=numv-1 176 : nbnn=2 177 : nbsous=0 178 : nbref=0 179 : segini meleme 180 : itypel=2 181 : nrigel=1 182 : segini mrigid 183 : coerig(1)=1.d0 184 : mtymat='RIGIDITE' 185 : nligrp=2 186 : nligrd=2 187 : segini descr 188 : lisinc(1)='ALFA' 189 : lisinc(2)='ALFA' 190 : lisdua(1)='FALF' 191 : lisdua(2)='FALF' 192 : noelep(1)=1 193 : noelep(2)=2 194 : noeled(1)=1 195 : noeled(2)=2 196 : segdes descr 197 : irigel(1,1)=meleme 198 : irigel(3,1)=descr 199 : nelrig=numv-1 200 : segini xmatri 201 : irigel(4,1)=xmatri 202 : irigel(5,1)=nifour 203 : do irig=1,numv-1 204 : num(1,irig)=nbno+irig 205 : num(2,irig)=nbno+irig+1 206 : if(irig.eq.1)re(1,1,irig)=mlree1.prog(irig) 207 : re(1,2,irig)=mlree2.prog(irig) 208 : re(2,1,irig)=mlree2.prog(irig) 209 : re(2,2,irig)=mlree1.prog(irig+1) 210 : enddo 211 : iptrid=mrigid 212 : RETURN 213 : END 214 : 215 : 216 : 217 : 218 : 219 :
© Cast3M 2003 - All rights reserved.
Disclaimer