1 : C QUELQU SOURCE CHAT 07/10/29 21:27:12 5940 2 : C OPERATEUR QUELQUONQUE 3 : C 4 : SUBROUTINE QUELQU 5 : C 6 : IMPLICIT INTEGER(I-N) 7 : IMPLICIT REAL*8(A-H,O-Z) 8 : C 9 : -INC CCOPTIO 10 : -INC CCGEOME 11 : -INC SMELEME 12 : -INC SMLREEL 13 : CHARACTER*4 ITSEG(2) 14 : DATA ITSEG/'SEG2','SEG3'/ 15 : SEGMENT IBUF(0) 15 : CALL LIRMOT(ITSEG,2,ITYP,1) 16 : IF (IERR.NE.0) RETURN 17 : SEGINI IBUF 18 : C 18 : CALL LIROBJ('LISTREEL',MLREE1,0,IRETO1) 19 : IF(IRETO1.NE.0)THEN 20 : SEGACT MLREE1 20 : CALL LIROBJ('LISTREEL',MLREE2,1,IRETO2) 21 : C ON DOIT LIRE UNE DEUXIEME PROGRESSION 22 : IF(IRETO2.EQ.0)RETURN 23 : SEGACT MLREE2 24 : IF(IDIM.EQ.3)THEN 24 : CALL LIROBJ('LISTREEL',MLREE3,1,IRETO3) 25 : C ON DOIT LIRE UNE TROISIEME PROGRESSION EN 3 D 26 : IF(IRETO3.EQ.0)RETURN 27 : SEGACT MLREE3 28 : ENDIF 29 : JG1=MLREE1.PROG(/1) 30 : JG2=MLREE2.PROG(/1) 31 : C LES DEUX PROGRESSIONS DOIVENT ETRE DE MEME LONGUEUR 31 : IF(JG2.NE.JG1)CALL ERREUR(577) 32 : IF(IDIM.EQ.3) THEN 33 : JG3=MLREE3.PROG(/1) 34 : C LES DEUX PROGRESSIONS DOIVENT ETRE DE MEME LONGUEUR 34 : IF(JG3.NE.JG1)CALL ERREUR(577) 35 : ENDIF 36 : C LES PROGRESSIONS DOIVENT AVOIR UNE LONGUEUR SUFFISANTE 36 : IF(JG1.LE.ITYP)CALL ERREUR(725) 37 : IF(ITYP.EQ.2)THEN 38 : C LIGNE CONSTITUEE DE SEG3 : 39 : C LES PROGRESSIONS DOIVENT AVOIR UNE LONGUEUR ADEQUATE 40 : IQUOT=(JG1-3)/2 41 : IREST=JG1-3-2*IQUOT 41 : IF(IREST.NE.0)CALL ERREUR(726) 42 : ENDIF 43 : ZG3=0.D0 44 : DO 10 IG1=1,JG1 45 : XG1=MLREE1.PROG(IG1) 46 : YG2=MLREE2.PROG(IG1) 47 : IF(IDIM.EQ.3)ZG3=MLREE3.PROG(IG1) 47 : CALL CREPO1(XG1,YG2,ZG3,IPO) 48 : IBUF(**)=IPO 49 : 10 CONTINUE 50 : SEGDES MLREE1 51 : IF(IRETO2.EQ.1)SEGDES MLREE2 52 : IF(IRETO3.EQ.1)SEGDES MLREE3 53 : ELSE 54 : * 55 : 20 CONTINUE 55 : CALL LIROBJ('POINT ',IP,0,IRETOU) 56 : IF (IRETOU.NE.0) THEN 57 : IBUF(**)=IP 58 : GOTO 20 59 : ENDIF 59 : CALL LIROBJ('MAILLAGE',IPT1,0,IRETOU) 60 : IF (IRETOU.EQ.1) THEN 61 : SEGACT IPT1 61 : IF ((IPT1.ITYPEL).NE.1) CALL ERREUR(426) 62 : NBNN = IPT1.NUM(/1) 63 : NBELEM = IPT1.NUM(/2) 64 : DO 21 I=1,NBELEM 65 : IBUF(**)= IPT1.NUM(1,I) 66 : 21 CONTINUE 67 : SEGDES IPT1 68 : ENDIF 69 : ENDIF 70 : NBP=IBUF(/1) 71 : NBNN=ITYP+1 72 : NBSOUS=0 73 : NBREF=0 74 : NBELEM=(NBP-1)/(NBNN-1) 74 : IF (NBELEM.LE.0.OR.NBELEM*(NBNN-1).NE.(NBP-1)) CALL ERREUR(20) 75 : IF (IERR.NE.0) RETURN 76 : SEGINI MELEME 77 : ITYPEL=NBNN 78 : DO 30 IEL=1,NBELEM 79 : DO 40 IN=1,NBNN 80 : NUM(IN,IEL)=IBUF((IEL-1)*(NBNN-1)+IN) 81 : 40 CONTINUE 82 : ICOLOR(IEL)=IDCOUL 83 : 30 CONTINUE 84 : SEGDES MELEME 85 : SEGSUP IBUF 85 : CALL ECROBJ('MAILLAGE',MELEME) 86 : END 87 : 88 : 89 : 90 : 91 : 92 : 93 : 94 : 95 : 96 : 97 :
© Cast3M 2003 - All rights reserved.
Disclaimer