1 : C LANCZ1 SOURCE PV 11/03/08 21:15:43 6888 2 : SUBROUTINE LANCZ1 (IPRIGI) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8 (A-H,O-Z) 5 : ************************************************************************ 6 : * 7 : * L A N C Z 1 8 : * ----------- 9 : * 10 : * FONCTION: 11 : * --------- 12 : * 13 : * DETERMINATION D'UN VECTEUR DE LANCZOS. 14 : * 15 : * MODE D'APPEL: 16 : * ------------- 17 : * 17 : * CALL LANCZ1 (IPRIGI) 18 : * 19 : * PARAMETRES: (E)=ENTREE (S)=SORTIE 20 : * ----------- 21 : * 22 : * +A1 REEL DP (E) 23 : * +B1 REEL DP (E) 24 : * +IPMV1 ENTIER (E) 25 : * IPRIGI ENTIER (E) POINTEUR SUR LA MATRICE DE RIGIDITE 26 : * (OBJET 'RIGIDITE') EVENTUELLEMENT DECALEE. 27 : * +NUMV ENTIER (E) 28 : * +NUMV1 ENTIER (E) 29 : * +IPKVV ENTIER E/S LISTE COMPLETEE EN SORTIE. 30 : * CETTE LISTE EST SUPPRIMEE LORSQU'ELLE 31 : * DEVIENT INUTILE, C-A-D LORS DU DERNIER 32 : * APPEL A "LANCZ1". 33 : * +IPV1 ENTIER E/S NOUVEAU 'CHPOINT' EN SORTIE. 34 : * +IPV0 ENTIER (E) 35 : * (S) EGAL AU "IPV1" D'ENTREE. 36 : * +IPVTKV ENTIER E/S LISTE COMPLETEE EN SORTIE. 37 : * CETTE LISTE EST SUPPRIMEE LORSQU'ELLE 38 : * DEVIENT INUTILE, C-A-D LORS DU DERNIER 39 : * APPEL A "LANCZ1". 40 : * +IPVV ENTIER E/S LISTE COMPLETEE EN SORTIE. 41 : * +S0 REEL DP E/S 42 : * +S1 REEL DP E/S 43 : * 44 : * + = PARAMETRE PASSE PAR LE COMMUN "CLANCZ" (DEFINITIONS 45 : * DETAILLEES DANS LE SOUS-PROGRAMME "SIMUL0"). 46 : * 47 : * LEXIQUE: (ORDRE ALPHABETIQUE) 48 : * -------- 49 : * 50 : * COMBI2 SUBROUT. 51 : * IPV2 ENTIER POINTEUR SUR LE NOUVEAU VECTEUR DE LANCZOS, A 52 : * UN CERTAIN NIVEAU DE TRANSFORMATION. 53 : * IPV2A ENTIER ANALOGUE A "IPV2". 54 : * 55 : * MODE DE FONCTIONNEMENT: 56 : * ----------------------- 57 : * 58 : * CALCUL DU VECTEUR "V2" A PARTIR DE "V0" ET "V1" (QUI SONT LES 2 59 : * VECTEURS DE LANCZOS PRECEDENTS): 60 : * 61 : * -1 62 : * V2 = |K| .|M|.V1 - SIGNE(V1.|K|.V1).A.V1 - SIGNE(V0.|K|.V0).B.V0 63 : * 64 : * AVEC: A = V1.|M|.V1 ET B = V0.|M|.V1 65 : * |K| : MATRICE DE RIGIDITE, |M| : MATRICE MASSE. 66 : * 67 : * "V2" EST THEORIQUEMENT K-ORTHOGONAL A TOUS LES VECTEURS DE 68 : * LANCZOS CALCULES PRECEDEMMENT (DONT, NOTAMMENT, "V0" ET "V1"). 69 : * 70 : * SOUS-PROGRAMMES APPELES: 71 : * ------------------------ 72 : * 73 : * COMBI3, DTCHPO, DTLCHP, DTLREE, EXTRA4, INSER1, INSER4, LANCZ4, 74 : * MUCPRI, NORME2, ORTHO2 (OU ORTHO1 ?), RESOU1, YTMX. 75 : * 76 : * AUTEUR, DATE DE CREATION: 77 : * ------------------------- 78 : * 79 : * PASCAL MANIGOT 24 AVRIL 1985 80 : * 81 : * LANGAGE: 82 : * -------- 83 : * 84 : * FORTRAN77 85 : * 86 : ************************************************************************ 87 : * 88 : -INC CCOPTIO 89 : SEGMENT IDEMEN(0) 90 : * 91 : * REGOUPEMENT DE RENSEIGNEMENTS POUR LES SOUS-PROGRAMMES "LANCZ.": 92 : COMMON/CLANCZ/ A1,B1,S0,S1,NOMBRV,NUMV,NUMV1,IPV0,IPV1 93 : & ,IPMV1,IPVV,IPKVV,IPVTKV,IPLMOX,IPLMOY 94 : * 95 : 96 : PARAMETER (UN = 1.D0 , XMOINS = -1.D0) 97 : PARAMETER (PRECIS = 1.D-15 , NFOIS = 1) 98 : * 99 : * 100 : * -- UNE ITERATION DE L'ALGORITHME DE LANCZOS -- 101 : * 102 : SEGINI IDEMEN 103 : IDEMEN(**)=IPMV1 104 : NOID=0 105 : NOEN=1 105 : CALL RESOU1 (IPRIGI,IDEMEN,NOID,NOEN,1D-18) 106 : SEGACT IDEMEN 107 : IPV2 = IDEMEN(1) 108 : SEGSUP IDEMEN 109 : IF (IERR .NE. 0) RETURN 109 : CALL DTCHPO (IPMV1) 110 : * 111 : IF (NUMV .GT. 1) THEN 112 : * 113 : C IF (NUMV .EQ. 2) THEN 113 : C CALL LANCZ4 (IPV2,UN,IPV1,COEFF1, IPV2A) 114 : C ELSE 115 : C COEFF2 = XMOINS * B1 * S0 115 : C CALL COMBI3 (IPV2,UN,IPV1,COEFF1,IPV0,COEFF2, IPV2A) 116 : C END IF 117 : C IF (IERR .NE. 0) RETURN 118 : COEFF1 = XMOINS * A1 * S1 118 : CALL ADCHPO(IPV2,IPV1,IRETT,1.D0,COEFF1) 119 : IF (NUMV .EQ. 2) THEN 120 : IPV2A=IRETT 121 : ELSE 122 : COEFF2 = XMOINS * B1 * S0 122 : CALL ADCHPO(IRETT,IPV0,IPV2A,1.D0,COEFF2) 122 : CALL DTCHPO(IRETT) 123 : END IF 123 : CALL DTCHPO (IPV2) 124 : IPV2 = IPV2A 125 : * 126 : IF (IIMPI .EQ. 369) THEN 126 : CALL NORME2 (IPV2,UN,IPRIGI, IPV2A,TEST1,IPLMOX, 127 : C IPLMOY,IPRX) 128 : IF (IERR .NE. 0) RETURN 129 : WRITE (IOIMP,2090) 130 : 2090 FORMAT (//' VERIFICATION, JUSTE APRES L''APPLICATION DE LA' 131 : & ,' FORMULE DE LANCZOS, DE L''ORTHOGONALITE DES '/ 132 : & ,' VECTEURS "VI" AVEC LE VECTEUR "V2" CREE (VALEURS ' 133 : & ,'A COMPARER A 1.) :'/) 134 : DO 80 IB80=1,NUMV1 134 : CALL EXTRA4 (IPVV,IB80, IPVI) 135 : IF (IERR .NE. 0) RETURN 135 : CALL YTMX (IPVI,IPV2A,IPRIGI, TEST1) 136 : IF (IERR .NE. 0) RETURN 137 : WRITE (IOIMP,*) 'VI.K.V2 = ',TEST1 138 : 80 CONTINUE 139 : * END DO 139 : CALL DTCHPO (IPV2A) 140 : END IF 141 : * 142 : IPV0 = IPV1 143 : S0 = S1 144 : * 145 : END IF 146 : * 147 : * -- NORMALISATION ET, POUR COMPENSER LES ERREURS D'ARRONDI, 148 : * "K-ORTHOGONALISATION" -- 149 : * 150 : IF (NUMV .EQ. 1) THEN 150 : CALL NORME2 (IPV2,UN,IPRIGI, IPV1,S1,IPLMOX,IPLMOY,IPKV1) 151 : IF (IERR .NE. 0) RETURN 151 : CALL DTCHPO (IPV2) 152 : ELSE 153 : * HYP: NUMV > 1 153 : CALL ORTHNG (IPV2,IPVV,IPVTKV,IPKVV,NUMV1,IPRIGI 154 : & ,S1,IPKV1, IPV1,IPLMOX,IPLMOY,precis,0) 155 : IF (IERR .NE. 0) RETURN 155 : CALL DTCHPO (IPV2) 156 : END IF 157 : * 158 : IF (IIMPI .EQ. 369) THEN 159 : WRITE (IOIMP,*) 'S1 = ',S1 160 : END IF 161 : * ON REMPLACE "S1" (TRES PROCHE DE +/-1) PAR +/-1 162 : S1 = SIGN(UN,S1) 163 : * 163 : CALL INSER4 (IPVV,NUMV,IPV1) 164 : IF (IERR .NE. 0) RETURN 165 : * 165 : CALL INSER1 (IPVTKV,NUMV,S1) 166 : IF (IERR .NE. 0) RETURN 167 : 167 : CALL INSER4 (IPKVV,NUMV,IPKV1) 168 : IF (IERR .NE. 0) RETURN 169 : 170 : END 171 : 172 : 173 : 174 : 175 :
© Cast3M 2003 - All rights reserved.
Disclaimer