1 : C POSCHA SOURCE CHAT 06/03/16 21:23:27 5336 2 : SUBROUTINE POSCHA(NAM,IPOSCH) 3 : IMPLICIT INTEGER(I-N) 4 : -INC CCOPTIO 5 : -INC CCNOYAU 6 : -INC CCASSIS 7 : CHARACTER*(*)NAM 8 : if(nbesc.ne.0) segact ipiloc*mod 9 : IL=LEN(NAM) 10 : IO=IPCHAR(/1) 11 : IA=0 12 : DO 56 I=1,IL 13 : IA = IA + ICHAR(NAM(I:I)) 14 : 56 CONTINUE 15 : * write(6,fmt='(''nam io lmncha ia'',a8,3i6)')nam,io,LMNCHA,ia 16 : DO 1 II=LMNCHA,1,-1 17 : IF( IPHCOD(II).NE.IA) GO TO 1 18 : ID=IPCHAR(II) 19 : IFI=IPCHAR(II+1) 20 : IF(IFI-ID.NE.IL) GO TO 1 21 : IF(NAM.NE.ICHARA(ID:IFI-1)) GO TO 1 22 : GO TO 2 23 : 1 CONTINUE 24 : 10 CONTINUE 25 : LMNCHA=LMNCHA+1 26 : M1=IPCHAR(LMNCHA) 27 : M=M1+IL 28 : * write(6,*) ' lmncha ' , lmncha , ' ipchar(/1))' , ipchar(/1) 29 : IF(LMNCHA+1.GT.IPCHAR(/1) .or. M.GT.ICHARA(/1)) THEN 30 : lmxx=xiflot(/1) 31 : lmll=iplogi(/1) 32 : lmmm=ichara(/1) 33 : if(M.gt.ichara(/1)) lmmm= m+1000 34 : lmcc= ipchar(/1) 35 : if(LMNCHA+1.GT.lmcc) LMcc=LMNCHA+200 36 : * write(6,*) ' lmxx,lmcc,lmmm,lmll',lmxx,lmcc,lmmm,lmll 37 : SEGADJ IPILOC 38 : ENDIF 39 : * write(6,*) ' lmncha ' , lmncha,' m ',m 40 : IPCHAR(LMNCHA+1)=M 41 : ICHARA(M1:M1+IL-1)=NAM 42 : IPHCOD(LMNCHA)=IA 43 : II=LMNCHA 44 : 2 CONTINUE 45 : IPOSCH=II 46 : if(nbesc.ne.0) segdes ipiloc 47 : * write(6,fmt='('' sortie poscha '',i8)') iposch 48 : RETURN 49 : END 50 :
© Cast3M 2003 - All rights reserved.
Disclaimer