Esope source files

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