1 : C KROT SOURCE FANDEUR 10/12/14 21:17:17 6812 2 : SUBROUTINE KROT(MCHPO1,MPOVA1,IGEOM1,MTABD) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8 (A-H,O-Z) 5 : C************************************************************************* 6 : C Operateur KROT 7 : C 8 : C Objet : determine le ROTATIONNEL d'un CHAMPOINT VECT SOMMET 9 : C 10 : C SYNTAXE : CHGR =KOPS CHPS 'ROT' TABDOM ; 11 : C TABDOM : Table DOMAINE contenant le support geometrique de CHPC 12 : C CHPS : CHAMPOINT SOMMET 13 : C CHGR : CHAMPOINT CENTRE 14 : C 15 : C************************************************************************* 16 : C Correction FD : Le signe est faux en repère cartésien 17 : C Ajout dans GIBI.ERREUR des messages 980 et 981 18 : C 19 : -INC SMTABLE 20 : POINTEUR MTABD.MTABLE 21 : -INC SMELEME 22 : POINTEUR MELEMS.MELEME,MELEMC.MELEME,IGEOM1.MELEME 23 : -INC CCOPTIO 24 : -INC SMCOORD 25 : -INC CCGEOME 26 : -INC SMCHPOI 27 : POINTEUR IZB.MCHPOI,IZBB.MPOVAL 28 : POINTEUR IZD.MCHPOI,IZDD.MPOVAL 29 : POINTEUR IZV.MCHPOI,IZVV.MPOVAL 30 : -INC SMLENTI 31 : POINTEUR IZIPAD.MLENTI 32 : -INC SIZFFB 33 : REAL*8 HRT(24),RPGJ(9),XYZI(8) 34 : CHARACTER*8 TYPE,TYPC,NOM0 35 : C*** 36 : IAXI=0 37 : IF(IFOMOD.EQ.0)IAXI=2 38 : 39 : NC=MPOVA1.VPOCHA(/2) 40 : NPT=MPOVA1.VPOCHA(/1) 41 : IF(NC.NE.IDIM)THEN 42 : C% L'objet %m1:8 n'a pas le bon nombre de composantes 43 : MOTERR(1: 8) = 'CHPOINT ' 43 : CALL ERREUR(980) 44 : RETURN 45 : ENDIF 46 : 47 : TYPE=' ' 47 : CALL ACMO(MTABD,'SOMMET',TYPE,MELEMS) 48 : 48 : CALL KRIPAD(IGEOM1,IZIPAD) 48 : CALL VERPAD(IZIPAD,MELEMS,IRET) 49 : IF(IRET.NE.0)THEN 50 : C% L'object %m1:8 n'a pas le bon support géométrique 51 : MOTERR(1: 8) = 'CHPOINT ' 51 : CALL ERREUR(981) 52 : RETURN 53 : ENDIF 54 : 55 : TYPE=' ' 55 : CALL ACMO(MTABD,'CENTRE',TYPE,MELEMC) 56 : TYPE='CENTRE' 57 : NC=IDIM 58 : IF(IDIM.EQ.2)NC=1 58 : CALL CRCHPT(TYPE,MELEMC,NC,MCHPOI) 58 : CALL LICHT(MCHPOI,MPOVAL,TYPE,IGEOM) 59 : 60 : TYPE=' ' 60 : CALL ACMO(MTABD,'MAILLAGE',TYPE,MELEME) 61 : 62 : SEGACT MELEME 63 : NBSOUS=LISOUS(/1) 64 : IF(NBSOUS.EQ.0)NBSOUS=1 65 : 66 : KK=0 67 : DO 1 L=1,NBSOUS 68 : IPT1=MELEME 69 : IF(NBSOUS.NE.1)IPT1=LISOUS(L) 70 : SEGACT IPT1 71 : NP=IPT1.NUM(/1) 72 : NEL=IPT1.NUM(/2) 73 : 74 : NOM0=NOMS(IPT1.ITYPEL)//' ' 74 : CALL KALPBG(NOM0,'FONFORM0',IZFFM) 75 : IF(IZFFM.EQ.0)GO TO 90 76 : SEGACT IZFFM*MOD 77 : IZHR=KZHR(1) 78 : SEGACT IZHR*MOD 79 : NPG=FN(/2) 80 : NES=GR(/1) 81 : 82 : DO 10 K=1,NEL 83 : KK=KK+1 84 : DO 9 I=1,NP 85 : J=IPT1.NUM(I,K) 86 : DO 12 N=1,IDIM 87 : XYZ(N,I)=XCOOR((J-1)*(IDIM+1) +N) 88 : 12 CONTINUE 89 : 9 CONTINUE 90 : 90 : CALL CALJBC(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES, 91 : *IDIM,NP,NPG,IAXI,AIRE) 92 : 93 : IF(IDIM.EQ.2)THEN 94 : UU=0.D0 95 : DO 35 I=1,NP 96 : IU = IZIPAD.LECT(IPT1.NUM(I,K)) 97 : UU = UU - ( MPOVA1.VPOCHA(IU,1)*HR(2,I,1) - 98 : & MPOVA1.VPOCHA(IU,2)*HR(1,I,1) ) 99 : 35 CONTINUE 100 : IF (IAXI.EQ.0) THEN 101 : VPOCHA(KK,1)= UU 102 : ELSE 103 : VPOCHA(KK,1)=-UU 104 : ENDIF 105 : ELSE 106 : UX=0.D0 107 : UY=0.D0 108 : UZ=0.D0 109 : DO 36 I=1,NP 110 : IU = IZIPAD.LECT(IPT1.NUM(I,K)) 111 : UX= UX - ( MPOVA1.VPOCHA(IU,2)*HR(3,I,1) - 112 : & MPOVA1.VPOCHA(IU,3)*HR(2,I,1) ) 113 : UY= UY - ( MPOVA1.VPOCHA(IU,3)*HR(1,I,1) - 114 : & MPOVA1.VPOCHA(IU,1)*HR(3,I,1) ) 115 : UZ= UZ - ( MPOVA1.VPOCHA(IU,1)*HR(2,I,1) - 116 : & MPOVA1.VPOCHA(IU,2)*HR(1,I,1) ) 117 : 36 CONTINUE 118 : VPOCHA(KK,1)=UX 119 : VPOCHA(KK,2)=UY 120 : VPOCHA(KK,3)=UZ 121 : ENDIF 122 : 123 : 10 CONTINUE 124 : SEGDES IPT1 125 : 1 CONTINUE 126 : SEGDES MPOVA1,MPOVAL 127 : SEGDES MCHPO1,MCHPOI 128 : SEGDES MELEME,IGEOM1,MELEMS 129 : C 130 : SEGSUP IZIPAD,IZFFM,IZHR 130 : CALL ECROBJ('CHPOINT ',MCHPOI) 131 : 132 : RETURN 133 : 134 : 90 CONTINUE 135 : WRITE(IOIMP,*)'Interruption anormale de KOPS option GRAD ' 135 : CALL ERREUR(5) 136 : RETURN 137 : 138 : 1001 FORMAT(20(1X,I5)) 139 : 1008 FORMAT(10(1X,A8)) 140 : 1002 FORMAT(10(1X,1PE11.4)) 141 : END 142 : 143 :
© Cast3M 2003 - All rights reserved.
Disclaimer