Télécharger poscha.eso

Retour à la liste

Numérotation des lignes :

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

© Cast3M 2003 - Tous droits réservés.
Mentions légales