1 : C EXTRAP SOURCE CHAT 05/01/12 23:53:57 5004 2 : SUBROUTINE EXTRAP(SHPTOT,NBPGAU,NBNN,NBNO) 3 : C================================================================ 4 : C CALCULE LES FONCTIONS D EXTRAPOLATIONS A PARTIR DES FONCTIONS 5 : C D INTERPOLATIONS 6 : C ENTREES 7 : C SHPTOT(6,NBNO,NBPGAU) = FONCTIONS D INTERPOLATIONS 8 : C NBPGAU = NOMBRE DE POINTS DE GAUSS 9 : C NBNN = NOMBRE DE NOEUDS 10 : C NBNO = NOMBRE DE FONCTIONS D'INTERPOLATION 11 : C SORTIES 12 : C SHPTOT(6,NBNO,NBPGAU) = FONCTIONS D EXTRAPOLATIONS STOKEES 13 : C SUR LA 6 IEME LIGNE 14 : C EBERSOLT NOVEMBRE 86 PAS PLUS DE 30 NOEUDS 15 : C================================================================ 16 : IMPLICIT INTEGER(I-N) 17 : IMPLICIT REAL*8(A-H,O-Z) 18 : PARAMETER(XZER=0.D0,UN=1.D0) 19 : DIMENSION SHPTOT(6,NBNO,*) 20 : DIMENSION XMAT(30,30),XVEC(30) 21 : C 22 : C PROTECTION PROVISOIRE 23 : IF(NBNN.NE.NBNO) RETURN 24 : C 25 : C UN SEUL POINT DE GAUSS 26 : C 27 : IF(NBPGAU.EQ.1) THEN 28 : DO 50 IA=1,NBNO 29 : SHPTOT(6,IA,1)=UN 30 : 50 CONTINUE 31 : C 32 : C PLUS D UN POINT DE GAUSS 33 : C 34 : ELSE IF(NBPGAU.GT.1) THEN 34 : CALL ZERO(XMAT,30,30) 35 : C 36 : C TRANSPOSE( A ) * A 37 : C 38 : DO 100 IA=1,NBNN 39 : DO 100 IB=1,NBNN 40 : CC = XZER 41 : DO 300 IC=1,NBPGAU 42 : CC = CC + SHPTOT(1,IA,IC)*SHPTOT(1,IB,IC) 43 : 300 CONTINUE 44 : XMAT(IA,IB)=CC 45 : 100 CONTINUE 46 : C 47 : C NOMBRE DE POINTS DE GAUSS DIFFERENTS DU NOMBRE DE NOEUDS 48 : C 49 : IF(NBPGAU.NE.NBNN) THEN 50 : C 51 : C SI ON A MOINS DE POINTS DE GAUSS QUE DE NOEUDS ON RAJOUTE 52 : C UN PEU DE PENALISATION EMPECHANT D OSCILLER SUR LES NOEUDS 53 : C 54 : IF(NBPGAU.LT.NBNN) THEN 55 : DO 705 IA=1,NBNN 55 : CALL ZERO(XVEC,30,1) 56 : XVEC(IA)=NBNN 57 : DO 706 IB=1,NBNN 58 : XVEC(IB)=XVEC(IB)-UN 59 : 706 CONTINUE 60 : C 61 : C ON LE DEFLATIONNE DE SES COMPOSANTES PARRALELLES AUX H 62 : C 63 : DO 710 IB=1,NBPGAU 64 : SCAL=XZER 65 : XXNORM=XZER 66 : DO 730 IC=1,NBNN 67 : SCAL=SCAL+SHPTOT(1,IC,IB)*XVEC(IC) 68 : XXNORM=XXNORM+SHPTOT(1,IC,IB)*SHPTOT(1,IC,IB) 69 : 730 CONTINUE 70 : IF(XXNORM.LT.1.E-7) GOTO 700 71 : SCAL=SCAL/XXNORM 72 : C 73 : DO 720 IC=1,NBNN 74 : XVEC(IC)=XVEC(IC)-SCAL*SHPTOT(1,IC,IB) 75 : 720 CONTINUE 76 : 710 CONTINUE 77 : C 78 : C ON RAJOUTE CES VECTEURS DANS LA PENALISATION 79 : C 80 : DO 750 IB=1,NBNN 81 : DO 750 IC=1,NBNN 82 : XMAT(IB,IC)= XVEC(IB)*XVEC(IC)+XMAT(IB,IC) 83 : 750 CONTINUE 84 : C 85 : 700 CONTINUE 86 : 705 CONTINUE 87 : C 88 : ENDIF 89 : C 90 : C ( T A P A ) ** -1 ALGO WILSON 91 : C 92 : DO 400 IEQ=1,NBNN 93 : DD = UN / XMAT(IEQ,IEQ) 94 : DO 410 IA=1,NBNN 95 : XMAT(IEQ,IA)=-XMAT(IEQ,IA)*DD 96 : 410 CONTINUE 97 : C 98 : DO 420 IA=1,NBNN 99 : IF(IA.EQ.IEQ) GOTO 420 100 : DO 430 IB=1,NBNN 101 : IF(IB.EQ.IEQ) GOTO 430 102 : XMAT(IA,IB)=XMAT(IA,IB)+XMAT(IA,IEQ)*XMAT(IEQ,IB) 103 : 430 CONTINUE 104 : 420 CONTINUE 105 : C 106 : DO 440 IA=1,NBNN 107 : XMAT(IA,IEQ)= XMAT(IA,IEQ)*DD 108 : 440 CONTINUE 109 : XMAT(IEQ,IEQ)= DD 110 : 400 CONTINUE 111 : C 112 : C (( T A . A ) ** -1 ) * ( T . A ) 113 : C 114 : DO 500 IA=1,NBNN 115 : DO 510 IB=1,NBPGAU 116 : CC=XZER 117 : DO 520 IC=1,NBNN 118 : CC=CC+XMAT(IA,IC)*SHPTOT(1,IC,IB) 119 : 520 CONTINUE 120 : SHPTOT(6,IA,IB)=CC 121 : 510 CONTINUE 122 : 500 CONTINUE 123 : C 124 : C NOMBRE DE POINTS DE GAUSS EGAL AUX NOMBRE DE NOEUDS 125 : C 126 : ELSE IF(NBNN.EQ.NBPGAU) THEN 127 : DO 600 IA=1,NBNN 128 : DO 600 IB=1,NBNN 129 : SHPTOT(6,IA,IB)=XMAT(IA,IB) 130 : 600 CONTINUE 131 : ENDIF 132 : ENDIF 133 : RETURN 134 : END 135 :
© Cast3M 2003 - All rights reserved.
Disclaimer