1 : C KGRAS SOURCE FANDEUR 10/12/14 21:17:16 6812 2 : SUBROUTINE KGRAS(MCHPO1,MPOVA1,IGEOM1,MTABD) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8 (A-H,O-Z) 5 : C************************************************************************* 6 : C Operateur KGRA 7 : C 8 : C Objet : determine le GRADIENT d un CHAMPOINT SOMMET 9 : C 10 : C SYNTAXE : CHGR =KOPS CHPS 'GRAD' 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 : -INC SMTABLE 17 : POINTEUR MTABD.MTABLE 18 : -INC SMELEME 19 : POINTEUR MELEMS.MELEME,IGEOM1.MELEME 20 : -INC CCOPTIO 21 : -INC SMCOORD 22 : -INC CCGEOME 23 : -INC SMCHPOI 24 : POINTEUR IZB.MCHPOI,IZBB.MPOVAL 25 : POINTEUR IZD.MCHPOI,IZDD.MPOVAL 26 : POINTEUR IZV.MCHPOI,IZVV.MPOVAL 27 : -INC SMLENTI 28 : POINTEUR IZIPAD.MLENTI 29 : -INC SIZFFB 30 : REAL*8 HRT(24),RPGJ(9),XYZI(8) 31 : CHARACTER*8 TYPE,TYPC,NOM0 32 : C*** 33 : 34 : IAXI=0 35 : IF(IFOMOD.EQ.0)IAXI=2 36 : 37 : NC=MPOVA1.VPOCHA(/2) 38 : NPT=MPOVA1.VPOCHA(/1) 39 : 40 : IF(NC.NE.1)THEN 41 : WRITE(6,*)' Opérateur KOPS option GRAD ' 42 : WRITE(6,*)' Le Champoint a plus d''une composante ',nc 43 : RETURN 44 : ENDIF 45 : 46 : TYPE=' ' 46 : CALL ACMO(MTABD,'SOMMET',TYPE,MELEMS) 47 : 47 : CALL KRIPAD(IGEOM1,IZIPAD) 47 : CALL VERPAD(IZIPAD,MELEMS,IRET) 48 : IF(IRET.NE.0)THEN 49 : C% Indice %m1:8 : L'objet %m9:16 n'a pas le bon support géométrique 50 : MOTERR(1: 8) = 'TETA1' 51 : MOTERR(9:16) = 'CHPOINT ' 52 : WRITE(IOIMP,*)'Operateur : KOPS GRADS' 52 : CALL ERREUR(788) 53 : RETURN 54 : ENDIF 55 : 55 : CALL LEKTAB(MTABD,'XXDIAGSI',MCHPO2) 55 : CALL LICHT(MCHPO2,MPOVA2,TYPE,IGEOM) 55 : CALL KRIPAD(MELEMS,MLENT2) 56 : TYPE='SOMMET' 56 : CALL CRCHPT(TYPE,MELEMS,IDIM,MCHPOI) 56 : CALL LICHT(MCHPOI,MPOVAL,TYPE,IGEOM) 57 : 58 : TYPE=' ' 58 : CALL ACMO(MTABD,'MAILLAGE',TYPE,MELEME) 59 : 60 : SEGACT MELEME 61 : NBSOUS=LISOUS(/1) 62 : IF(NBSOUS.EQ.0)NBSOUS=1 63 : 64 : KK=0 65 : DO 1 L=1,NBSOUS 66 : IPT1=MELEME 67 : IF(NBSOUS.NE.1)IPT1=LISOUS(L) 68 : SEGACT IPT1 69 : NP=IPT1.NUM(/1) 70 : NEL=IPT1.NUM(/2) 71 : 72 : NOM0=NOMS(IPT1.ITYPEL)//' ' 72 : CALL KALPBG(NOM0,'FONFORM ',IZFFM) 73 : IF(IZFFM.EQ.0)GO TO 90 74 : SEGACT IZFFM*MOD 75 : IZHR=KZHR(1) 76 : SEGACT IZHR*MOD 77 : NPG=FN(/2) 78 : NES=GR(/1) 79 : 80 : DO 10 K=1,NEL 81 : KK=KK+1 82 : DO 9 I=1,NP 83 : J=IPT1.NUM(I,K) 84 : DO 12 N=1,IDIM 85 : XYZ(N,I)=XCOOR((J-1)*(IDIM+1) +N) 86 : 12 CONTINUE 87 : 9 CONTINUE 88 : 88 : CALL CALJBC(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES, 89 : *IDIM,NP,NPG,IAXI,AIRE) 90 : 91 : DO 35 I=1,NP 92 : I2 = MLENT2.LECT(IPT1.NUM(I,K)) 93 : 94 : DO 36 N=1,IDIM 95 : UU=0.D0 96 : DO 37 LG=1,NPG 97 : GNUL=0.D0 98 : DO 38 J=1,NP 99 : J1 = IZIPAD.LECT(IPT1.NUM(J,K)) 100 : GNUL = GNUL + MPOVA1.VPOCHA(J1,1)*HR(N,J,LG) 101 : 38 CONTINUE 102 : UU= UU + FN(I,LG)*PGSQ(LG)*GNUL 103 : 37 CONTINUE 104 : VPOCHA(I2,N)=VPOCHA(I2,N)+UU 105 : 36 CONTINUE 106 : 35 CONTINUE 107 : 108 : 10 CONTINUE 109 : SEGDES IPT1 110 : 1 CONTINUE 111 : NPT=VPOCHA(/1) 112 : DO 2 I=1,NPT 113 : DO 2 N=1,IDIM 114 : VPOCHA(I,N)=VPOCHA(I,N)/MPOVA2.VPOCHA(I,1) 115 : 2 CONTINUE 116 : 117 : SEGDES MPOVA1,MPOVAL,MPOVA2 118 : SEGDES MCHPO1,MCHPOI,MCHPO2 119 : SEGDES MELEME,IGEOM1,MELEMS 120 : C 121 : SEGSUP IZIPAD,IZFFM,IZHR,MLENT2 121 : CALL ECROBJ('CHPOINT ',MCHPOI) 122 : 123 : RETURN 124 : 125 : 90 CONTINUE 126 : WRITE(6,*)'Interruption anormale de KOPS option GRAD ' 127 : RETURN 128 : 129 : 1001 FORMAT(20(1X,I5)) 130 : 1008 FORMAT(10(1X,A8)) 131 : 1002 FORMAT(10(1X,1PE11.4)) 132 : END 133 : 134 :
© Cast3M 2003 - All rights reserved.
Disclaimer