1 : C GRAAMO SOURCE CHAT 05/01/13 00:19:25 5004 2 : C GRAAMO SOURCE WP 23/08/94 3 : C SUBROUTINE GRAAMO ( IPLSNO, IPRIGI ) 4 : ************************************************************************ 5 : * 6 : * GRAAMO 7 : * ----------- 8 : * 9 : * FONCTION: 10 : * --------- 11 : * 12 : * ORTHONORMALISER UNE SUITE DE 'CHPOINT' PAR RAPPORT A UNE RIGIDITE 13 : * si dans le processus on detecte des vecteurs du noyau on les 14 : * enleve 15 : * 16 : * MODE D'APPEL: 17 : * ------------- 18 : * 18 : * CALL GRAAMO ( IPLSNO, IPRIGI ) 19 : * 20 : * PARAMETRES: (E)=ENTREE (S)=SORTIE 21 : * ----------- 22 : * 23 : * IPLSNO ENTIER (E) POINTEUR DE L'OBJET 'LISTCHPO' CONTENANT 24 : * LA SUITE DE 'CHPOINT' NON ORTHOGONAUX, 25 : * MAIS LINEAIREMENT INDEPENDANTS. 26 : * 27 : * IPLSNO ENTIER (S) POINTEUR DE L'OBJET 'LISTCHPO' CONTENANT 28 : * LA SUITE DE 'CHPOINT' ORTHOGONAUX. 29 : * 30 : * IPRIGI ENTIER (E) POINTEUR SUR L'OBJET 'RIGIDITE' PAR 31 : * RAPPORT AUQUEL ON ORTHOGONALISE. 32 : * 33 : * 34 : * 35 : * MODE DE FONCTIONNEMENT: 36 : * ----------------------- 37 : * 38 : * PROCEDE D'ORTHOGONALISATION DE GRAM-SCHMITH. 39 : * 40 : * AUTEUR, DATE DE CREATION: 41 : * ------------------------- 42 : * 43 : * A.M. JOLIVALT, W. PASILLAS 06 / 07 / 94. ( ESOPE ) 44 : * 45 : *************************************************** 46 : 47 : SUBROUTINE GRAAMO ( IPLSNO, IPRIGI ) 48 : 49 : IMPLICIT INTEGER(I-N) 50 : IMPLICIT REAL*8 (A-H,O-Z) 51 : 52 : -INC CCOPTIO 53 : -INC SMLCHPO 54 : -INC CCREEL 55 : 56 : ****** 57 : * -- ARGUMENTS -- 58 : *** 59 : POINTEUR IPLSNO.MLCHPO 60 : INTEGER IPRIGI 61 : 62 : ****** 63 : * -- VARIABLES LOCALES -- 64 : *** 65 : POINTEUR IPLSO.MLCHPO 66 : INTEGER ILDIM, IB100, IB200 67 : INTEGER IPTMP, IPTMP1, IPCHPO, IPLMOT 68 : CHARACTER*4 MOTCLE 69 : ****** 70 : * -- ON CREE UNE 'LISTCHPO' VIDE -- 71 : *** 72 : N1 = 0 73 : SEGINI ,IPLSO 74 : segdes iplso 75 : 76 : ****** 77 : * -- DANS LAQUELLE ON INSERE DES VECTEURS ORTHOGONALISES 78 : * PAR GRAAM1 ET NORMES PAR NORMA1. -- 79 : *** 79 : CALL MOTS1( IPLMOT, MOTCLE ) 80 : IF ( IERR .NE. 0 ) RETURN 81 : SEGACT ,IPLSNO 82 : ILDIM = IPLSNO.ICHPOI(/1) 83 : 84 : DO 100 IB100 = 1, ILDIM 85 : IPCHPO = IPLSNO.ICHPOI( IB100 ) 85 : CALL GRAAM1 ( IPCHPO, IPRIGI, IPLSO, IPTMP ) 86 : IF ( IERR .NE. 0 ) RETURN 87 : * on teste si la matrice est singuliere 88 : * on ne garde pas les vecteurs du noyau 88 : call xtmx(iptmp,iprigi,xm) 89 : if (abs(xm).gt.1d2*xpetit) then 89 : CALL NORMA1 ( IPTMP, IPLMOT, MOTCLE, IPTMP1 ) 90 : IF ( IERR .NE. 0 ) RETURN 90 : CALL DTCHPO ( IPTMP ) 91 : IF ( IERR .NE. 0 ) RETURN 92 : segact iplso*mod 93 : IPLSO.ICHPOI(**) = IPTMP1 94 : segdes iplso 95 : endif 96 : 100 CONTINUE 97 : 98 : ****** 99 : * -- ON EFFACE L'ANCIENNE LISTE -- 100 : *** 101 : DO 200 IB200 = 1, ILDIM 102 : IPCHPO = IPLSNO.ICHPOI(IB200) 102 : CALL DTCHPO ( IPCHPO ) 103 : IF ( IERR .NE. 0 ) RETURN 104 : 200 CONTINUE 104 : CALL DTLCHP ( IPLSNO ) 105 : segsup iplsno 106 : ****** 107 : * -- ON RETOURNE LA NOUVELLE LISTE -- 108 : *** 109 : IPLSNO = IPLSO 110 : 111 : RETURN 112 : END 113 : 114 : 115 :
© Cast3M 2003 - All rights reserved.
Disclaimer