1 : C KPSOML SOURCE MAGN 10/05/18 21:16:04 6675 2 : SUBROUTINE KPSOML 3 : C************************************************************************ 4 : C 5 : C OBJET : 6 : C 7 : C CALCUL DE LA MATRICE MASSE ---> Creation d'un CHAML 8 : C 9 : C 10 : C SYNTAXE : 11 : C 12 : C RES = KPSO OBJ1 <'AXI' i> <'IMPR'> ; 13 : C 14 : C OBJ1 : Table DOMAINE 15 : C 16 : C AXI : Calcule en coordonee cylindrique 2D 17 : C i=2 axe de symetrie oy 18 : C 19 : C 20 : C************************************************************************ 21 : IMPLICIT INTEGER(I-N) 22 : IMPLICIT REAL*8 (A-H,O-Z) 23 : -INC CCGEOME 24 : -INC CCOPTIO 25 : -INC SMELEME 26 : -INC SMTABLE 27 : -INC SMCOORD 28 : -INC SMCHAML 29 : -INC SMCHPOI 30 : -INC SIZFFB 31 : CHARACTER*8 NOM0,CHAI,LISMO(1),TYPE,TYPC 32 : DATA LISMO/'IMPR '/ 33 : C *************************************************************** 34 : 35 : IMPR=0 36 : IAXI=0 37 : IF(IFOMOD.EQ.0)IAXI=2 38 : 38 : CALL LITABS('DOMAINE ',MTABD,1,1,IRET) 39 : IF(IRET.EQ.0)THEN 40 : WRITE(6,*)' On attend une table de soustype DOMAINE' 41 : RETURN 42 : ENDIF 43 : TYPE=' ' 43 : CALL ACMO(MTABD,'MAILLAGE',TYPE,MELEME) 44 : IF(TYPE.NE.'MAILLAGE')RETURN 45 : 46 : 19 CONTINUE 46 : CALL LIRCHA(CHAI,0,IRET) 47 : IF(IRET.EQ.0)GO TO 20 47 : CALL OPTLI(IP,LISMO,CHAI,1) 48 : IF(IP.EQ.0)THEN 49 : WRITE(6,*)' On attend le mot cle IMPR ' 50 : RETURN 51 : ENDIF 52 : IMPR=1 53 : GO TO 19 54 : 55 : 20 CONTINUE 56 : 57 : 58 : C CREATION DE LA DIAGONALE 58 : CALL CRCHPE(MELEME,1,MCHELM) 59 : SEGACT MCHELM 60 : NBSOUS=IMACHE(/1) 61 : 62 : 63 : C 64 : C BOUCLE SUR LES TYPES D'ELEMENTS ET CALCUL 65 : C 66 : DO 1 KSOUS=1,NBSOUS 67 : MCHAML=ICHAML(KSOUS) 68 : SEGACT MCHAML 69 : MELVAL=IELVAL(1) 70 : SEGACT MELVAL*MOD 71 : IPT1=IMACHE(KSOUS) 72 : SEGACT IPT1 73 : 74 : NP=IPT1.NUM(/1) 75 : NEL=IPT1.NUM(/2) 76 : C 77 : NOM0=NOMS(IPT1.ITYPEL)//' ' 77 : CALL KALPBG(NOM0,'FONFORM ',IZFFM) 78 : SEGACT IZFFM*MOD 79 : IZHR=KZHR(1) 80 : SEGACT IZHR*MOD 81 : C 82 : NPG=FN(/2) 83 : NES=GR(/1) 84 : 85 : IF(IMPR.NE.0)THEN 86 : WRITE(6,*)' SUB CADGSI : NES,NP,NPG,IDIM,NEL=' 87 : & ,NES,NP,NPG,IDIM,NEL 88 : ENDIF 89 : C 90 : DO 10 K=1,NEL 91 : C 92 : NPGR=0 93 : IF(IAXI.NE.0)NPGR=NPG 94 : C 95 : DO 12 I=1,NP 96 : J=IPT1.NUM(I,K) 97 : DO 12 N=1,IDIM 98 : XYZ(N,I)=XCOOR((J-1)*(IDIM+1) +N) 99 : 12 CONTINUE 100 : 100 : CALL CALJBC(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,IDIM,NP,NPG,IAXI,AIRE) 101 : 102 : IF(IMPR.NE.0)THEN 103 : WRITE(6,*)' SUB kpsoml : AIRE=',AIRE 104 : WRITE(6,*)' SUB kpsoml : LER ' 105 : WRITE(6,1001)(IPT1.NUM(I,K),I=1,NP) 106 : WRITE(6,*)' SUB kpsoml : XYZ ' 107 : WRITE(6,1002)((XYZ(N,I),N=1,2),I=1,NP) 108 : ENDIF 109 : C 110 : DO 3 J=1,NP 111 : SJ=0.D0 112 : DO 4 L=1,NPG 113 : 4 SJ=SJ+FN(J,L)*PGSQ(L) 114 : 3 VELCHE(J,K)=SJ 115 : 116 : IF(IMPR.NE.0)THEN 117 : WRITE(6,*)' SUB CADGSI : CALCUL DE LA DIAGONALE' 118 : WRITE(6,1003)(K,VELCHE(I,K),I=1,NP) 119 : WRITE(6,*)' FIN DE CADGSI' 120 : ENDIF 121 : C 122 : 10 CONTINUE 123 : SEGDES MELVAL,MCHAML 124 : SEGDES IPT1 125 : SEGSUP IZFFM,IZHR 126 : 1 CONTINUE 127 : 128 : SEGDES MCHELM 128 : CALL ECROBJ('MCHAML ',MCHELM) 129 : RETURN 130 : 1001 FORMAT(20(1X,I5)) 131 : 1002 FORMAT(10(1X,1PE11.4)) 132 : 1003 FORMAT(6(1X,I7,1X,1PE11.4)) 133 : END 134 : 135 : 136 : 137 : 138 : 139 : 140 : 141 : 142 : 143 : 144 : 145 :
© Cast3M 2003 - All rights reserved.
Disclaimer