1 : C HRSI SOURCE MAGN 10/05/18 21:15:30 6675 2 : SUBROUTINE HRSI 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8 (A-H,O-Z) 5 : C************************************************************************ 6 : C I OBJET 7 : C ---------- 8 : C CALCUL DES HR (GRADIENTS FF) ELEMENTAIRES SOUS INTEGRES 9 : C 10 : C 11 : C II SYNTAXE 12 : C ___________ 13 : C 14 : C RES = HRSI OBJ1 <'AXI' i > <'IMPR'> 15 : C 16 : C OBJ1 : Objet MAILLAGE 17 : C AXI DISCRETISATION CORDONNEES CYLINDRIQUE (2D) 18 : C i=1 AXE DE SYMETRIE y=0 19 : C i=2 AXE DE SYMETRIE x=0 20 : C IMPR : impressions de controle 21 : 22 : C RES : Resultat objet de type MATESI 23 : C************************************************************************ 24 : C 25 : -INC CCGEOME 26 : -INC CCOPTIO 27 : -INC SMTABLE 28 : POINTEUR MTABD.MTABLE 29 : -INC SMMATRIK 30 : -INC SIZFFB 31 : -INC SMCOORD 32 : -INC SMELEME 33 : POINTEUR MELEMZ.MELEME 34 : CHARACTER*8 NMD,NOM0,NOM,TYPE,LISTM(1) 35 : DIMENSION HRT(24),RPGJ(9),XYZI(24) 36 : PARAMETER (NTB=1) 37 : CHARACTER*8 LTAB(NTB) 38 : DIMENSION KTAB(NTB) 39 : DATA LTAB/'DOMAINE '/ 40 : DATA LISTM/'IMPR '/ 41 : C***************************************************************************** 42 : 42 : CALL LITABS(LTAB,KTAB,NTB,1,IRET) 43 : IF (IERR.NE.0) RETURN 44 : MTABD=KTAB(1) 45 : 46 : IAXI=0 47 : IF(IFOMOD.EQ.0)IAXI=2 48 : IMPAP=0 49 : 1 CONTINUE 49 : CALL LIRCHA(NOM,0,IRET) 50 : IF(IRET.NE.0)THEN 50 : CALL OPTLI(IP,LISTM,NOM,1) 51 : IF(IP.EQ.0)THEN 52 : WRITE(6,*)' On attend le mot cle IMPR' 53 : C Il manque la donnée d'un mot clé. 53 : CALL ERREUR(498) 54 : RETURN 55 : ELSE 56 : IMPAP=1 57 : GO TO 1 58 : ENDIF 59 : ENDIF 60 : C 61 : TYPE='MAILLAGE' 61 : CALL ACMO(MTABD,'MAILLAGE',TYPE,MELEMZ) 61 : CALL ACMO(MTABD,'SOMMET',TYPE,MELES1) 61 : CALL ACMO(MTABD,'CENTRE',TYPE,MELEMC) 62 : IF (IERR.NE.0) RETURN 63 : 64 : SEGACT MELEMZ 65 : NBSOUS=MELEMZ.LISOUS(/1) 66 : IF(NBSOUS.EQ.0)NBSOUS=1 67 : C 68 : C ON CREE L OBJET MATRIK 69 : C 70 : NRIGE=7 71 : NKID =9 72 : NKMT =7 73 : NMATRI=1 74 : SEGINI MATRIK 75 : IRIGEL(1,1)=MELEMZ 76 : IRIGEL(2,1)=MELEMZ 77 : IRIGEL(7,1)=1 78 : NBOP=0 79 : NBELC=0 80 : NBME=1 81 : IF(IAXI.NE.0)NBME=2 82 : SEGINI IMATRI 83 : IRIGEL(4,1)=IMATRI 84 : C KGEOS=MELES1 85 : KSPGP=MELES1 86 : C KGEOC=MELEMC 87 : KSPGD=MELEMC 88 : 89 : C 90 : C BOUCLE SUR LES TYPES D'ELEMENTS ET CALCUL 91 : C 92 : DO 81 KSOUS=1,NBSOUS 93 : IF(NBSOUS.EQ.1)IPT1=MELEMZ 94 : IF(NBSOUS.NE.1)IPT1=MELEMZ.LISOUS(KSOUS) 95 : SEGACT IPT1 96 : 97 : NOM0=NOMS(IPT1.ITYPEL)//' ' 98 : C 98 : CALL KALPBG(NOM0,'FONFORM0',IZFFM) 99 : SEGACT IZFFM*MOD 100 : IZHR=KZHR(1) 101 : SEGACT IZHR*MOD 102 : 103 : NBEL=IPT1.NUM(/2) 104 : IF(IAXI.NE.0)THEN 105 : NP=1 106 : MP=1 107 : SEGINI IPM1 108 : LIZAFM(KSOUS,2)=IPM1 109 : ENDIF 110 : NP=IPT1.NUM(/1) 111 : NES=GR(/1) 112 : NPG=GR(/3) 113 : MP=NES 114 : IESP=MP 115 : SEGINI IZAFM 116 : C 117 : SEGACT IPT1 118 : LIZAFM(KSOUS,1)=IZAFM 119 : 120 : IF(IMPAP.NE.0)THEN 121 : WRITE(6,*)' CREATION SEGMENT MATRIK ' 122 : WRITE(6,*)' FONCTIONS DE FORME ' 123 : WRITE(6,1002)((FN(MM,II),MM=1,NP),II=1,NPG) 124 : WRITE(6,*)' FONCTIONS DE FORME ' 125 : WRITE(6,1002)((GR(1,MM,II),MM=1,NP),II=1,NPG) 126 : WRITE(6,1002)((GR(2,MM,II),MM=1,NP),II=1,NPG) 127 : ENDIF 128 : 129 : DO 8 K=1,NBEL 130 : IJ=1 131 : DO 9 I=1,NP 132 : J=IPT1.NUM(I,K) 133 : DO 9 N=1,IESP 134 : XYZI(IJ )=XCOOR((J-1)*(IDIM+1)+N) 135 : IJ=IJ+1 136 : 9 CONTINUE 137 : C 137 : CALL CALJBC(FN,GR,PG,XYZI,HRT,PGSQ,RPGJ,NES, 138 : *IESP,NP,NPG,IAXI,AIRE) 139 : IH=0 140 : DO 98 I=1,NP 141 : DO 98 N=1,IESP 142 : IH=IH+1 143 : AM(K,I,N)=HRT(IH) 144 : 98 CONTINUE 145 : IF(IAXI.NE.0)IPM1.AM(K,1,1)=RPGJ(1) 146 : 147 : 148 : 8 CONTINUE 149 : IF(IPT1.NE.MELEMZ)SEGDES IPT1 150 : SEGDES IZAFM 151 : IF(IAXI.NE.0)SEGDES IPM1 152 : SEGSUP IZFFM,IZHR 153 : 81 CONTINUE 154 : SEGDES MELEMZ,IMATRI 155 : 32 CONTINUE 156 : SEGDES MATRIK 156 : CALL ECROBJ('MATRIK',MATRIK) 157 : RETURN 158 : 1002 FORMAT(10(1X,1PE11.4)) 159 : END 160 : 161 : 162 : 163 : 164 : 165 : 166 : 167 : 168 : 169 : 170 : 171 :
© Cast3M 2003 - All rights reserved.
Disclaimer