Télécharger la plaquette Cast3M


fr en

Télécharger kctrp1.eso

Retour à la liste

Numérotation des lignes : 

kctrp1

  1. C KCTRP1    SOURCE    PV        20/04/02    21:15:24     10567          
  2.       SUBROUTINE KCTRP1(MTABLE,IPOINT,IKAS)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8 (A-H,O-Z)
  5.  
  6. -INC PPARAM
  7. -INC CCOPTIO
  8. -INC CCGEOME
  9. -INC SMTABLE
  10. -INC SMCOORD
  11. -INC SMELEME
  12.       POINTEUR MELEMI.MELEME
  13.       DIMENSION XA(3,64),XL(3,4),XG(3,4)
  14.       CHARACTER*8 TYPE,NOME
  15.  
  16.       IPOINT=0
  17.       TYPE=' '
  18.       CALL ACMO(MTABLE,'MACRO',TYPE,MACRO)
  19.       TYPE=' '
  20.       CALL ACMO(MTABLE,'QUADRATI',TYPE,MQ)
  21.       IF(MACRO.EQ.0.AND.MQ.EQ.0)THEN
  22.  
  23.       TYPE=' '
  24.       CALL ACMO(MTABLE,'CENTRE',TYPE,MELEMC)
  25.       IF(MELEMC.EQ.0)THEN
  26.       MOTERR(1: 8) = 'DOMAINE.'
  27.       MOTERR(9:16) = 'CENTRE  '
  28.       CALL ERREUR(792)
  29.       IPOINT=0
  30.       RETURN
  31.       ENDIF
  32.  
  33.       ELSE
  34.       IF(MACRO.NE.0)MELEMI=MACRO
  35.       IF(MQ   .NE.0)MELEMI=MQ
  36.  
  37.       CALL ECROBJ('MAILLAGE',MELEMI)
  38.       CALL NBEL
  39.       CALL LIRENT(NBELEM,1,IRET)
  40.       IF(IRET.EQ.0)RETURN
  41.       NBSOUS=0
  42.       NBREF=0
  43.       NBNN=IDIM+1
  44.       SEGINI MELEME
  45.       IF(IDIM.EQ.2)ITYPEL=4
  46.       IF(IDIM.EQ.3)ITYPEL=23
  47.       segact mcoord*mod
  48.       NBV0=nbpts
  49.       NBPTS=NBV0+(NBELEM*(IDIM+1))
  50.       SEGADJ MCOORD
  51.       K0=NBV0
  52.       KE=0
  53.  
  54.  
  55.       SEGACT MELEMI
  56.       NBSOUL=MELEMI.LISOUS(/1)
  57.       IF(NBSOUL.EQ.0)NBSOUL=1
  58.  
  59.       DO 1 L=1,NBSOUL
  60.       IPT1=MELEMI
  61.       IF(NBSOUL.NE.1)IPT1=MELEMI.LISOUS(L)
  62.       SEGACT IPT1
  63.       NP=IPT1.NUM(/1)
  64.       NEL=IPT1.NUM(/2)
  65.  
  66.       NOME=NOMS(IPT1.ITYPEL)//'    '
  67.       CALL KXL(NOME,'P1',XL)
  68.  
  69.       DO 2 K=1,NEL
  70.       KE=KE+1
  71.       DO 3 M=1,IDIM
  72.       DO 3 I=1,NP
  73.       NI=IPT1.NUM(I,K)
  74.       XA(M,I)=XCOOR((NI-1)*(IDIM+1)    +M)
  75.  3    CONTINUE
  76.  
  77.       CALL FFQ(NOME,XA,XL,XG,IDIM,NBNN)
  78.  
  79.       DO 5 MI=1,NBNN
  80.       K0=K0+1
  81.       DO 4 M=1,IDIM
  82.       XCOOR((K0-1)*(IDIM+1)    +M)=XG(M,MI)
  83.  4    CONTINUE
  84.       NUM(MI,KE)=K0
  85.  5    CONTINUE
  86.  2    CONTINUE
  87.  1    CONTINUE
  88.       segact mcoord
  89.  
  90.       CALL ECMO(MTABLE,'ELTP1NC ','MAILLAGE',MELEME)
  91.       CALL ECRCHA('POI1')
  92.       CALL ECROBJ('MAILLAGE',MELEME)
  93.       CALL PRCHAN
  94.       CALL LIROBJ('MAILLAGE',MELEM1,1,IRET)
  95.       CALL ECMO(MTABLE,'CENTREP1','MAILLAGE',MELEM1)
  96.       ENDIF
  97.  
  98.       IF(IKAS.EQ.1)IPOINT=MELEM1
  99.       IF(IKAS.EQ.2)IPOINT=MELEME
  100.  
  101.       RETURN
  102.  1002 FORMAT(10(1X,1PE11.4))
  103.       END
  104.  
  105.  
  106.  
  107.  
  108.  
  109.  
  110.  
  111.  
  112.  
  113.  
  114.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales