C KCTRP1 SOURCE CHAT 07/10/29 21:21:33 5940 SUBROUTINE KCTRP1(MTABLE,IPOINT,IKAS) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) -INC CCOPTIO -INC CCGEOME -INC SMTABLE -INC SMCOORD -INC SMELEME POINTEUR MELEMI.MELEME DIMENSION XA(3,64),XL(3,4),XG(3,4) CHARACTER*8 TYPE,NOME IPOINT=0 TYPE=' ' CALL ACMO(MTABLE,'MACRO',TYPE,MACRO) TYPE=' ' CALL ACMO(MTABLE,'QUADRATI',TYPE,MQ) IF(MACRO.EQ.0.AND.MQ.EQ.0)THEN TYPE=' ' CALL ACMO(MTABLE,'CENTRE',TYPE,MELEMC) IF(MELEMC.EQ.0)THEN MOTERR(1: 8) = 'DOMAINE.' MOTERR(9:16) = 'CENTRE ' CALL ERREUR(792) IPOINT=0 RETURN ENDIF ELSE IF(MACRO.NE.0)MELEMI=MACRO IF(MQ .NE.0)MELEMI=MQ CALL ECROBJ('MAILLAGE',MELEMI) CALL NBEL CALL LIRENT(NBELEM,1,IRET) IF(IRET.EQ.0)RETURN NBSOUS=0 NBREF=0 NBNN=IDIM+1 SEGINI MELEME IF(IDIM.EQ.2)ITYPEL=4 IF(IDIM.EQ.3)ITYPEL=23 NBV0=XCOOR(/1)/(IDIM+1) NBPTS=NBV0+(NBELEM*(IDIM+1)) SEGADJ MCOORD K0=NBV0 KE=0 SEGACT MELEMI NBSOUL=MELEMI.LISOUS(/1) IF(NBSOUL.EQ.0)NBSOUL=1 DO 1 L=1,NBSOUL IPT1=MELEMI IF(NBSOUL.NE.1)IPT1=MELEMI.LISOUS(L) SEGACT IPT1 NP=IPT1.NUM(/1) NEL=IPT1.NUM(/2) NOME=NOMS(IPT1.ITYPEL)//' ' CALL KXL(NOME,'P1',XL) DO 2 K=1,NEL KE=KE+1 DO 3 M=1,IDIM DO 3 I=1,NP NI=IPT1.NUM(I,K) XA(M,I)=XCOOR((NI-1)*(IDIM+1) +M) 3 CONTINUE CALL FFQ(NOME,XA,XL,XG,IDIM,NBNN) DO 5 MI=1,NBNN K0=K0+1 DO 4 M=1,IDIM XCOOR((K0-1)*(IDIM+1) +M)=XG(M,MI) 4 CONTINUE NUM(MI,KE)=K0 5 CONTINUE 2 CONTINUE 1 CONTINUE CALL ECMO(MTABLE,'ELTP1NC ','MAILLAGE',MELEME) CALL ECRCHA('POI1') CALL ECROBJ('MAILLAGE',MELEME) CALL PRCHAN CALL LIROBJ('MAILLAGE',MELEM1,1,IRET) CALL ECMO(MTABLE,'CENTREP1','MAILLAGE',MELEM1) ENDIF IF(IKAS.EQ.1)IPOINT=MELEM1 IF(IKAS.EQ.2)IPOINT=MELEME RETURN 1002 FORMAT(10(1X,1PE11.4)) END