Sources Esope | Cast3M

kpsoml
C KPSOML    SOURCE    PV        22/04/21    21:15:06     11344          
      SUBROUTINE KPSOML
C************************************************************************
C
C   OBJET :
C
C   CALCUL DE LA MATRICE MASSE  ---> Creation d'un CHAML
C
C
C   SYNTAXE :
C
C   RES = KPSO OBJ1 &lt;'AXI' i> &lt;'IMPR'> ;
C
C   OBJ1 : Table DOMAINE
C
C   AXI  : Calcule en coordonee cylindrique 2D
C   i=2    axe de symetrie oy
C
C
C************************************************************************
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
-INC CCGEOME
 
-INC PPARAM
-INC CCOPTIO
-INC SMELEME
-INC SMTABLE
-INC SMCOORD
-INC SMCHAML
-INC SMCHPOI
-INC SIZFFB
      dimension mtabd(1)
      CHARACTER*8 NOM0,CHAI,LISMO(1),TYPE,TYPC
      DATA LISMO/'IMPR    '/
C   ***************************************************************
 
      IMPR=0
      IAXI=0
      IF(IFOMOD.EQ.0)IAXI=2
 
      CALL LITABS('DOMAINE ',MTABD,1,1,IRET)
      IF(IRET.EQ.0)THEN
      WRITE(6,*)' On attend une table de soustype DOMAINE'
      RETURN
      ENDIF
      TYPE=' '
      CALL ACMO(MTABD(1),'MAILLAGE',TYPE,MELEME)
      IF(TYPE.NE.'MAILLAGE')RETURN
 
 19   CONTINUE
      CALL LIRCHA(CHAI,0,IRET)
      IF(IRET.EQ.0)GO TO 20
      CALL OPTLI(IP,LISMO,CHAI,1)
      IF(IP.EQ.0)THEN
      WRITE(6,*)' On attend le mot cle IMPR '
      RETURN
      ENDIF
      IMPR=1
      GO TO 19
 
 20   CONTINUE
 
 
C CREATION DE LA DIAGONALE
      CALL CRCHPE(MELEME,1,MCHELM)
      SEGACT MCHELM
      NBSOUS=IMACHE(/1)
 
 
C
C        BOUCLE SUR LES TYPES D'ELEMENTS ET CALCUL
C
      DO 1 KSOUS=1,NBSOUS
      MCHAML=ICHAML(KSOUS)
      SEGACT MCHAML
      MELVAL=IELVAL(1)
      SEGACT MELVAL*MOD
      IPT1=IMACHE(KSOUS)
      SEGACT IPT1
 
      NP=IPT1.NUM(/1)
      NEL=IPT1.NUM(/2)
C
      NOM0=NOMS(IPT1.ITYPEL)//'    '
      CALL KALPBG(NOM0,'FONFORM ',IZFFM)
      SEGACT IZFFM*MOD
      IZHR=KZHR(1)
      SEGACT IZHR*MOD
C
      NPG=FN(/2)
      NES=GR(/1)
 
      IF(IMPR.NE.0)THEN
      WRITE(6,*)' SUB CADGSI :   NES,NP,NPG,IDIM,NEL='
     & ,NES,NP,NPG,IDIM,NEL
      ENDIF
C
      DO 10 K=1,NEL
C
      NPGR=0
      IF(IAXI.NE.0)NPGR=NPG
C
      DO 12 I=1,NP
      J=IPT1.NUM(I,K)
      DO 12 N=1,IDIM
      XYZ(N,I)=XCOOR((J-1)*(IDIM+1)    +N)
 12   CONTINUE
 
      CALL CALJBC(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,IDIM,NP,NPG,IAXI,AIRE)
 
      IF(IMPR.NE.0)THEN
      WRITE(6,*)' SUB kpsoml : AIRE=',AIRE
      WRITE(6,*)' SUB kpsoml : LER '
      WRITE(6,1001)(IPT1.NUM(I,K),I=1,NP)
      WRITE(6,*)' SUB kpsoml : XYZ '
      WRITE(6,1002)((XYZ(N,I),N=1,2),I=1,NP)
      ENDIF
C
      DO 3 J=1,NP
      SJ=0.D0
      DO 4 L=1,NPG
 4     SJ=SJ+FN(J,L)*PGSQ(L)
 3    VELCHE(J,K)=SJ
 
      IF(IMPR.NE.0)THEN
      WRITE(6,*)' SUB CADGSI : CALCUL DE LA DIAGONALE'
      WRITE(6,1003)(K,VELCHE(I,K),I=1,NP)
      WRITE(6,*)' FIN DE CADGSI'
      ENDIF
C
 10   CONTINUE
      SEGDES MELVAL,MCHAML
      SEGDES IPT1
      SEGSUP IZFFM,IZHR
 1    CONTINUE
 
      SEGDES MCHELM
      CALL ECROBJ('MCHAML  ',MCHELM)
      RETURN
 1001 FORMAT(20(1X,I5))
 1002 FORMAT(10(1X,1PE11.4))
 1003 FORMAT(6(1X,I7,1X,1PE11.4))
      END