1 : C DANS SOURCE PV 13/04/12 21:15:23 7756 2 : C teste si un listentier dans un autre 3 : subroutine dans 4 : IMPLICIT INTEGER(I-N) 5 : IMPLICIT REAL*8(A-H,O-Z) 6 : -INC CCOPTIO 7 : -INC SMLENTI 8 : -INC SMLREEL 9 : -INC SMELEME 10 : character*4 chaopt(2) 11 : data chaopt/'SEQU','QUEL'/ 12 : c 13 : c premiere option un listenti dans un autre 14 : c 15 : imo=0 15 : call lirmot(chaopt,2,imo,0) 15 : call lirobj('LISTENTI',mlent1,0,iretou) 16 : if( iretou.eq.0) go to 100 16 : call lirobj('LISTENTI',mlent2,1,iretou) 17 : if (ierr.ne.0) return 18 : segact mlent1,mlent2 19 : lon=mlent1.lect(/1) 20 : do 10 i=0,mlent2.lect(/1)-1,lon 21 : do 20 j=1,lon 22 : if (mlent1.lect(j).ne.mlent2.lect(i+j)) goto 30 23 : 20 continue 24 : * ok on a trouve 24 : call ecrlog(.true.) 25 : segdes mlent1,mlent2 26 : return 27 : 30 continue 28 : 10 continue 28 : call ecrlog(.false.) 29 : segdes mlent1,mlent2 30 : return 30 : 100 call lirobj('LISTREEL',mlree1,0,iretou) 31 : if (iretou.eq.0) go to 300 32 : if( ierr.ne.0) return 32 : call lirobj('LISTREEL',mlree2,0,iretou) 33 : if( iretou.eq.0) go to 200 34 : C 35 : C deuxieme option un listreel dans un autre listreel 36 : c 37 : prec = 1.d30 38 : segact mlree1,mlree2 39 : lon = mlree2.prog(/1) 40 : do 101 i=1,lon-1 41 : prec = min ( prec ,abs (mlree2.prog(i)-mlree2.prog(i+1))) 42 : 101 continue 43 : prec=prec/ 1.d5 44 : IF(IMO.ne.2) then 45 : * option sequentiel 46 : lon = mlree1.prog(/1) 47 : do 110 i=0,mlree2.prog(/1)-1,lon 48 : do 120 j=1,lon 49 : if (abs(mlree1.prog(j)-mlree2.prog(i+j)).gt.prec) goto 130 50 : 120 continue 51 : * ok on a trouve 51 : call ecrlog(.true.) 52 : segdes mlree1,mlree2 53 : return 54 : 130 continue 55 : 110 continue 55 : call ecrlog(.false.) 56 : segdes mlree1,mlree2 57 : return 58 : else 59 : * option quel 60 : do 140 i=1,mlree1.prog(/1) 61 : ab = mlree1.prog(i) 62 : do 150 j=1,mlree2.prog(/1) 63 : if( abs(mlree2.prog(j)-ab) . le. prec) go to 140 64 : 150 continue 64 : call ecrlog(.false.) 65 : segdes mlree1,mlree2 66 : return 67 : 140 continue 67 : call ecrlog(.true.) 68 : segdes mlree1,mlree2 69 : return 70 : endif 70 : 200 call lirree(xva,0,iretou) 71 : if(iretou.eq.0) then 71 : call erreur(21) 72 : endif 73 : c 74 : c test si un reel est dans un listreel 75 : c 76 : prec = 1.d30 77 : segact mlree1 78 : lon = mlree1.prog(/1) 79 : do 201 i=1,lon-1 80 : if(mlree1.prog(i)-mlree1.prog(i+1).eq.0.d0)go to 201 81 : prec = min ( prec ,abs (mlree1.prog(i)-mlree1.prog(i+1))) 82 : 201 continue 83 : prec= prec / 1.d5 84 : do 202 i=1,lon 85 : if( abs ( xva - mlree1.prog(i)).lt. prec) go to 203 86 : 202 continue 86 : call ecrlog(.false.) 87 : segdes mlree1 88 : return 88 : 203 call ecrlog(.true.) 89 : segdes mlree1 90 : return 91 : 92 : 300 continue 92 : call lirobj('POINT',ip1,1,iretou) 93 : if (ierr.ne.0) return 93 : call lirobj('MAILLAGE',meleme,0,iretou) 94 : if(iretou.eq.0) then 94 : call erreur(21) 95 : endif 95 : call ecrobj('MAILLAGE',meleme) 95 : call ecrcha('POI1') 95 : call prchan 95 : call lirobj('MAILLAGE',meleme,0,iretou) 96 : if (ierr.ne.0) return 97 : segact meleme 98 : do kp=1,num(/2) 99 : if (ip1.eq.num(1,kp)) then 99 : call ecrlog(.true.) 100 : return 101 : endif 102 : enddo 102 : call ecrlog(.false.) 103 : return 104 : end 105 : 106 : 107 : 108 : 109 : 110 : 111 :
© Cast3M 2003 - All rights reserved.
Disclaimer