Télécharger pfmors.eso

Retour à la liste

Numérotation des lignes :

  1. C PFMORS SOURCE PV 16/11/17 22:00:56 9180
  2. SUBROUTINE PFMORS(ASSTAB,MATRIK,LL)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. C ******************************************
  6. C * Subroutine calculant le profil morse *
  7. C * a partir de ASSTAB *
  8. C * Entree /Sortie : MATRIK *
  9. C * Sortie : ASSTAB *
  10. C ******************************************
  11.  
  12.  
  13. SEGMENT ASSTAB
  14. INTEGER ITAB(NBCOMP,NTA)
  15. ENDSEGMENT
  16.  
  17. INTEGER DUA,PRI,MAXDUA,MAXPRI
  18.  
  19. SEGACT MATRIK*MOD
  20. SEGACT ASSTAB
  21.  
  22. NBCOMP=ITAB(/1)
  23. NTA=ITAB(/2)
  24.  
  25. MINCP=KMINCP
  26. MINCD=KMINCD
  27.  
  28. SEGACT MINCP,MINCD
  29. NPTP=MINCP.MPOS(/1)
  30. NPTD=MINCD.MPOS(/1)
  31. NBIP=MINCP.MPOS(/2)-1
  32. NBID=MINCD.MPOS(/2)-1
  33.  
  34. NTT=NPTD
  35. NJA=NPTP
  36. C On initialise le segment PMORS
  37. SEGINI PMORS
  38.  
  39. M=0
  40. MAXPRI=0
  41. MAXDUA=0
  42.  
  43.  
  44. DO I=1,NTA
  45. NB=ITAB(1,I)
  46. NINCD=MINCD.NPOS(I+1)-MINCD.NPOS(I)
  47.  
  48. c WRITE(6,*) 'NINCD',NINCD
  49. LLL=0
  50. DO L=1,NINCD
  51. LLL=LLL+1
  52. 300 CONTINUE
  53. IF (MINCD.MPOS(I,LLL).EQ.0) THEN
  54. LLL=LLL+1
  55. GOTO 300
  56. END IF
  57. DUA=MINCD.NPOS(I)+MINCD.MPOS(I,LLL)-1
  58. MAXDUA=MAX(DUA,MAXDUA)
  59.  
  60. 100 CONTINUE
  61. IF (NTT.LT.DUA) THEN
  62. NTT=NTT+100
  63. SEGADJ PMORS
  64. GOTO 100
  65. END IF
  66. c WRITE(6,*) 'DUA',DUA,'M',M
  67. IA(DUA)=M+1
  68. c WRITE(6,*) 'NB', NB
  69.  
  70. DO J=1,NB
  71. c WRITE(6,*) 'J',J,'I',I
  72. PRI=ITAB(J+1,I)
  73. c WRITE(6,*) 'PRI',PRI,'NINCP',MINCP.NPOS(PRI+1)-
  74. c & MINCP.NPOS(PRI)
  75. NINCP=MINCP.NPOS(PRI+1)-MINCP.NPOS(PRI)
  76.  
  77. KK=0
  78. DO K=1,NINCP
  79. KK=KK+1
  80. PRI=ITAB(J+1,I)
  81. M=M+1
  82. c WRITE(6,*) 'M',M
  83. 200 CONTINUE
  84. IF (NJA.LT.M) THEN
  85. NJA=NJA+100
  86. SEGADJ PMORS
  87. GOTO 200
  88. END IF
  89. c WRITE(6,*) 'PRI',PRI,'MINCP.NPOS(PRI)',
  90. c & MINCP.NPOS(PRI),
  91. c & 'MINCP.MPOS(PRI,K)',MINCP.MPOS(PRI,K)
  92. 350 CONTINUE
  93. IF (MINCP.MPOS(PRI,KK).EQ.0) THEN
  94. KK=KK+1
  95. GOTO 350
  96. END IF
  97.  
  98. PRI=MINCP.NPOS(PRI)+MINCP.MPOS(PRI,KK)-1
  99. c WRITE(6,*) 'M',M,'PRI',PRI
  100. MAXPRI=MAX(MAXPRI,PRI)
  101. JA(M)=PRI
  102. END DO
  103. END DO
  104. END DO
  105. END DO
  106.  
  107.  
  108. NTT=MAXDUA
  109. NJA=M
  110.  
  111. SEGADJ PMORS
  112. C On oublie pas le dernier
  113. IA(MAXDUA+1)=M+1
  114.  
  115. SEGDES PMORS
  116. SEGDES MINCP,MINCD
  117. SEGSUP ASSTAB
  118.  
  119. IRIGEL(5,LL)=PMORS
  120. KNTTP=MAXPRI
  121. KNTTD=MAXDUA
  122. SEGDES MATRIK
  123. RETURN
  124.  
  125. END
  126.  
  127.  
  128.  
  129.  
  130.  
  131.  

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