1 : C EXCOOR SOURCE PASCAL 12/12/12 21:15:06 7605 2 : C EXTRAIT LA IEME COORDONNEE D'UN POINT. SI IDIM+1 REND LA DENSITE 3 : C SI PAS DE NOMBRE SPECIFIE REND TOUTES LES COORDONNEES 4 : C DANS LE CAS D'OBJET MELEME FAIT LA MEME CHOSE SAUF QU'IL CREE 5 : C AUTANT DE CHPOIN QUE IDIM 6 : 7 : SUBROUTINE EXCOOR 8 : 9 : IMPLICIT INTEGER(I-N) 10 : IMPLICIT REAL*8(A-H,O-Z) 11 : 12 : -INC CCOPTIO 13 : -INC SMCOORD 14 : -INC SMCHAML 15 : 16 : PARAMETER ( NBTYP = 4 ) 17 : CHARACTER*8 LISTYP(NBTYP),MOTYPE 18 : * 19 : DATA LISTYP/'POINT ','MAILLAGE','MCHAML ', 'CHPOINT '/ 20 : * 21 : * LECTURE DE LA COMPOSANTE ( EVENTUELLE ) 22 : * 22 : CALL LIRENT(ICOMP,0,IRT2) 23 : * 23 : CALL QUETYP(MOTYPE,0,IRETOU) 24 : IF (IRETOU.EQ.0) THEN 24 : CALL ERREUR ( 533) 25 : RETURN 26 : ENDIF 26 : CALL PLACE(LISTYP,NBTYP,IPOS,MOTYPE) 27 : IF (IPOS.EQ.0) THEN 28 : MOTERR(1:8)=MOTYPE 28 : CALL ERREUR(39) 29 : RETURN 30 : ENDIF 30 : CALL LIROBJ(MOTYPE,IRT1,1,IRETOU) 31 : * 32 : IF(IPOS.NE.1) THEN 33 : IF((ICOMP.LE.0.OR.ICOMP.GT.IDIM+1).AND.IRT2.EQ.1) THEN 34 : INTERR(1)=ICOMP 34 : CALL ERREUR(36) 35 : RETURN 36 : ENDIF 37 : IF(IRT2.EQ.0) THEN 38 : IVAL=0 39 : ELSE 40 : IVAL=ICOMP 41 : ENDIF 42 : ENDIF 43 : * 44 : GO TO (100,200,300,400),IPOS 45 : C 46 : C CAS DU POINT 47 : C 48 : 100 CONTINUE 49 : IP=IRT1 50 : IC=ICOMP 50 : IF (IRT2.EQ.1.AND.(IC.LE.0.OR.IC.GT.IDIM+1)) CALL ERREUR(36) 51 : IF (IERR.NE.0) RETURN 52 : SEGACT MCOORD 53 : IREF=(IP-1)*(IDIM+1) 54 : IF(IRT2.EQ.0) GOTO 10 55 : XRET=XCOOR(IREF+IC) 55 : CALL ECRREE(XRET) 56 : GOTO 20 57 : 10 CONTINUE 58 : DO 11 I=1,IDIM 59 : II=IDIM+1-I 60 : XRET=XCOOR(IREF+II) 60 : CALL ECRREE(XRET) 61 : 11 CONTINUE 62 : 20 CONTINUE 63 : RETURN 64 : C 65 : C CAS DU MELEME 66 : C 67 : 200 CONTINUE 67 : CALL CHPCOO(IVAL,IRT1) 68 : RETURN 69 : C 70 : C CAS DU MCHAML 71 : C 72 : 300 CONTINUE 73 : IPCHE1=0 74 : IPCHE2=0 75 : IPCHE3=0 76 : MCHEL1=IRT1 77 : SEGACT,MCHEL1 78 : I1=MCHEL1.IMACHE(/1) 79 : C MCHAML VIDE 80 : IF (I1.EQ.0) THEN 81 : SEGDES,MCHEL1 82 : N1=0 83 : N3=0 84 : L1=8 85 : SEGINI,MCHEL2 86 : MCHEL2.IFOCHE=IFOUR 87 : MCHEL2.TITCHE=' ' 88 : SEGDES,MCHEL2 89 : IPCHE1=MCHEL2 90 : IF (IVAL.EQ.0) THEN 91 : IF (IDIM.EQ.2) THEN 92 : SEGINI,MCHEL3 93 : MCHEL3.IFOCHE=IFOUR 94 : MCHEL3.TITCHE=' ' 95 : SEGDES,MCHEL3 96 : IPCHE2=MCHEL3 97 : ELSEIF (IDIM.EQ.3) THEN 98 : SEGINI,MCHEL3 99 : MCHEL3.IFOCHE=IFOUR 100 : MCHEL3.TITCHE=' ' 101 : SEGDES,MCHEL3 102 : IPCHE2=MCHEL3 103 : SEGINI,MCHEL4 104 : MCHEL4.IFOCHE=IFOUR 105 : MCHEL4.TITCHE=' ' 106 : SEGDES,MCHEL4 107 : IPCHE3=MCHEL4 108 : ENDIF 109 : ENDIF 110 : C MCHAML NON VIDE 111 : ELSE 111 : CALL CHELCO(IVAL,IRT1,IPCHE1,IPCHE2,IPCHE3) 112 : ENDIF 113 : IF(IERR.EQ.0)THEN 113 : CALL ECROBJ('MCHAML',IPCHE1) 113 : IF(IPCHE2.NE.0)CALL ECROBJ('MCHAML',IPCHE2) 113 : IF(IPCHE3.NE.0)CALL ECROBJ('MCHAML',IPCHE3) 114 : ENDIF 115 : RETURN 116 : C 117 : C CAS DU CHPOINT 118 : C 119 : 400 CONTINUE 119 : CALL CHPTCO(IVAL,IRT1) 120 : 121 : RETURN 122 : END 123 : 124 : 125 :
© Cast3M 2003 - All rights reserved.
Disclaimer