1 : C RESHPT SOURCE CHAT 08/09/17 21:15:52 6160 2 : SUBROUTINE RESHPT(NNNN,NBSH,IELE,MELE,NPINT,IPT,IRET) 3 : C======================================================= 4 : C 5 : C MET LES VALEURS DES FONCTIONS DE FORMES DANS SHPTOT 6 : C ET LES COORDOONEES REDUITES LES POIDS D INTEGRATION 7 : C DANS QSIGAU ETAGAU DZEGAU POIGAU ; LE TOUT EST 8 : C MIS DANS LE POINTEUR MINTE SON POINTEUR EST IPT 9 : C NNN =NOMBRE DE POINTS DE GAUSS 10 : C NBSH =NOMBRE DE FONCTIONS D'INTERPOLATION 11 : C IELE =NUMERO DE L ELEMENT DANS NOMS (VOIR CCGEOME ) 12 : C MELE =NUMERO DE L ELEMENT DANS NOMTP 13 : C NPINT=NOMBRE DE POINTS D'INTEGRATION DONS LE CAS DES 14 : C ELEMENTS COQUES INTEGRES 15 : C IPT = POINTEUR SUR MINTE 16 : C IRET=1 OU 0 SUIVANT QUE MINTE A ETE CREEE OU PAS 17 : C 18 : C CETTE ROUTINE GERE LES MESSAGES D ERREURS 19 : C PROVENANT DE L INCOMPATIBILTE ENTRE NOMS 20 : C D ELEMENTS,NOMBRE DE POINTS DE GAUSS,ET FONCTIONS DE FORME 21 : C 22 : C======================================================= 23 : IMPLICIT INTEGER(I-N) 24 : IMPLICIT REAL*8(A-H,O-Z) 25 : -INC CCGEOME 26 : -INC SMINTE 27 : -INC CCOPTIO 28 : SEGMENT/SHXX/(SHPXXX(6,NBB)*D) 29 : DIMENSION IMIPOR(5) 30 : C 31 : DATA IMIPOR/4,8,14,23,16/ 32 : C 33 : NPINT1=NPINT 34 : NNN=NNNN 35 : IRET=1 36 : NBBB=NBNNE(IELE) 37 : NBNO=NBSH 38 : 39 : IP1C=0 40 : IF (MELE.GE.195.AND.NPINT.EQ.1) THEN 41 : IP1C=1 42 : NPINT1=0 43 : ELSEIF (MELE.GE.195.AND.NPINT.EQ.2) THEN 44 : IP1C=2 45 : NPINT1=0 46 : ENDIF 47 : C WRITE(6,*)'IP1C=',IP1C 48 : 48 : CALL DONRED(NNN,IELE,MELE,NBNO,NPINT1,IPT1,IRT1) 49 : IF (IRT1.EQ.1) GOTO 10 50 : C 51 : C MESSAGE D ERREUR NBPGAU ET IELE NON COMPATIBLES POUR 52 : C L INSTANT 53 : C 54 : MOTERR(1:4)=NOMS(IELE) 55 : INTERR(1)=NNN 55 : CALL ERREUR(67) 56 : IRET=0 57 : GOTO 666 58 : 10 CONTINUE 59 : MINTE=IPT1 60 : SEGACT MINTE*MOD 61 : C 62 : DO 110 IA=1,NNN 63 : DO 110 IB=1,6 64 : DO 110 IC=1,NBNO 65 : SHPTOT(IB,IC,IA)=0.D0 66 : 110 CONTINUE 67 : NBB=NBNO 68 : SEGINI SHXX 69 : * 70 : * BOUCLE SUR LES POINTS 71 : * 72 : DO 100 II=1,NNN 73 : C INSERER EVENTUELLEMENT UN INDICATEUR DE SUCCES 74 : XX=QSIGAU(II) 75 : YY=ETAGAU(II) 76 : ZZ=DZEGAU(II) 77 : IF(MELE.EQ.96) THEN 77 : CALL SHAP96(XX,YY,ZZ,IELE,SHPXXX,IRT2) 78 : ELSE IF(MELE.EQ.128) THEN 78 : CALL SHROT3(XX,YY,ZZ,IELE,SHPXXX,IRT2) 79 : ELSEIF ((MELE.GE.111).AND.(MELE.LE.122)) THEN 79 : CALL SHPOLY(XX,YY,ZZ,II,MELE,SHPXXX,IRT2) 80 : ELSEIF ((MELE.GE.223).AND.(MELE.LE.236).AND.(IP1C.EQ.0)) THEN 80 : CALL SHMACR(XX,YY,ZZ,MELE,SHPXXX,IRT2) 81 : ELSEIF ((MELE.GE.195).AND.(IP1C.EQ.1)) THEN 81 : CALL SHP1CE(XX,YY,ZZ,MELE,SHPXXX,IRT2) 82 : ELSEIF(MELE.EQ.260) then 82 : CALL shSHB8(XX,shpxxx) 83 : irt2=1 84 : ELSE 84 : CALL SHAPE(XX,YY,ZZ,IELE,SHPXXX,IRT2) 85 : ENDIF 86 : C 87 : C TRAITEMENT SPECIAL MILIEU POREUX 88 : C 89 : IF(MELE.GE.79.AND.MELE.LE.83) THEN 89 : CALL SHAPE(XX,YY,ZZ,IMIPOR(MELE-78), 90 : . SHPXXX(1,NBBB+1),IRT2) 91 : * 92 : ELSE IF(MELE.GE.173.AND.MELE.LE.177) THEN 92 : CALL SHAPE(XX,YY,ZZ,IMIPOR(MELE-172), 93 : . SHPXXX(1,NBBB+1),IRT2) 94 : * 95 : ELSE IF(MELE.GE.178.AND.MELE.LE.182) THEN 95 : CALL SHAPE(XX,YY,ZZ,IMIPOR(MELE-177), 96 : . SHPXXX(1,NBBB+1),IRT2) 97 : * 98 : ENDIF 99 : C 100 : DO 200 ID=1,6 101 : DO 200 NO=1,NBNO 102 : SHPTOT(ID,NO,II)=SHPXXX(ID,NO) 103 : * WRITE(*,*) 'SHP (',ID,',',NO,') =', SHPXXX(ID,NO) 104 : 200 CONTINUE 105 : 100 CONTINUE 106 : C 107 : C ON CALCULE LES FONCTIONS D EXTRAPOLATIONS 108 : C 108 : if( mele.ne.260) CALL EXTRAP(SHPTOT,NNN,NBBB,NBNO) 109 : C 110 : SEGSUP SHXX 111 : IF (IRT2.EQ.1) GOTO 20 112 : C 113 : C ERREUR LES FONCTIONS DE FORME PAS ENCORE IMPLEMENTEES 114 : C 115 : MOTERR(1:4)=NOMS(IELE) 115 : CALL ERREUR(68) 116 : IRET=0 117 : SEGSUP MINTE 118 : GOTO 666 119 : 20 IPT=IPT1 120 : SEGDES MINTE 121 : 666 CONTINUE 122 : RETURN 123 : END 124 : 125 : 126 : 127 : 128 : 129 : 130 : 131 : 132 : 133 : 134 : 135 : 136 : 137 :
© Cast3M 2003 - All rights reserved.
Disclaimer