Télécharger nouins2.eso

Retour à la liste

Numérotation des lignes :

  1. C NOUINS2 SOURCE CHAT 12/03/26 21:15:15 7335
  2. C nouins version esclave
  3. C
  4. SUBROUTINE NOUINS2
  5. IMPLICIT INTEGER(I-N)
  6. -INC CCASSIS
  7. -INC CCOPTIO
  8. -INC CCNOYAU
  9. -INC SMCOORD
  10. -INC SMLMOTS
  11. logical ilog , LLLERR
  12. real*8 reel
  13. character*72 chaine
  14. character*8 ityp
  15. *
  16. * initialisation de lotesc
  17. ith=0
  18. call ooonth(ith)
  19. call ooohor(0,ith)
  20. * write (6,*) ' dans nouins2 ',ith
  21. if ((ith.eq.0) .and. lotrma) then
  22. call erreur(5)
  23. * le maitre travaille comme un assistant
  24. mesins = mescl(ith)
  25. mestra = imestr
  26. lotrma = .false.
  27. lotesc = .true.
  28. goto 3457
  29. end if
  30. *
  31. mescla = imescl(ith)
  32. mestra = imestr
  33. mesins = mescl(ith)
  34. * est on en situation d'erreur????
  35. merres = ierres
  36. segact merres
  37. LLLERR = LOSIER
  38. segdes merres
  39. * mettre les resultats dans la pile de l'esclave
  40. IIRES = 0
  41. do 10 iop=1,90
  42. call quetyp(ityp,0,iretou)
  43. if (iretou.eq.0) goto 11
  44. IIRES = IIRES + 1
  45. mesres=esrees(iop)
  46. if (mesres.eq.0) then
  47. moterr(1:8) = ityp
  48. moterr(9:16) = ' '
  49. call erreur(11)
  50. goto 11
  51. end if
  52. * Il faut activer mesres avant nesres pour eviter des problemes
  53. * d'interferences et de validiter de LOREMP
  54. if (iimpi .eq. 1234) write(ioimp,*) 'mise a jour de',mesres
  55. segact mesres*mod
  56. nesres = iesres
  57. segact nesres*mod
  58. LOREMP = .TRUE.
  59. esrety=ityp
  60. if (ityp.eq.'LOGIQUE ') then
  61. call lirlog(ilog,1,iretou)
  62. esrelo=ilog
  63. elseif(ityp.eq.'FLOTTANT') then
  64. call lirree(reel,1,iretou)
  65. esrere=reel
  66. elseif (ityp.eq.'MOT ') then
  67. call lircha(chaine,1,iretou)
  68. esrech=chaine
  69. else
  70. call lirobj(ityp,iob,1,iretou)
  71. esreva=iob
  72. endif
  73. ****** CJY
  74. if (ith.ne.0) then
  75. segdes nesres*record
  76. else
  77. segdes nesres
  78. endif
  79. segdes mesres
  80. 10 continue
  81. 11 continue
  82. * en situation d'erreur on genere des objets de type ANNULE
  83. IF ( LLLERR ) IIRES = 0
  84. C -
  85. C - il faut verifier si il ne reste pas d'objets ESCLAVE dans la pile
  86. DO II = IIRES+1 , 90
  87. MESRES = esrees(II)
  88. IF ( MESRES .EQ. 0 ) THEN
  89. GO TO 4321
  90. ELSE
  91. SEGACT MESRES*MOD
  92. nesres = iesres
  93. SEGACT NESRES*MOD
  94. LOREMP = .TRUE.
  95. ESRETY = 'ANNULE '
  96. ESIERR = JJJERR
  97. if (ith.ne.0) then
  98. SEGDES NESRES*RECORD
  99. else
  100. SEGDES NESRES
  101. endif
  102. SEGDES MESRES
  103. END IF
  104. END DO
  105. 4321 CONTINUE
  106. * Y a t il eu une erreur ?
  107. MLMOT1 = jpcar1
  108. IF ( JJJERR .NE. 0 .OR. LLLERR ) THEN
  109. C JYYY segact mesins
  110. merres = ierres
  111. segact merres*mod
  112. NERR = liserr(/2)
  113. IF ( NBERR .eq. NERR) then
  114. NERR = NERR + 2
  115. segadj merres
  116. END IF
  117. NBERR = NBERR + 1
  118. LISERR(1,NBERR) = JJJERR
  119. LISERR(2,NBERR) = MLMOT1
  120. LISERR(3,NBERR) = ith
  121. segdes mlmot1
  122. C JYYY segdes mesins*record
  123. segdes merres
  124. ELSE
  125. SEGSUP MLMOT1
  126. END IF
  127. ** plus utile menage travaille correctement sur les mescla
  128. *** CALL LIBSEG ( mescla )
  129. SEGSUP mescla
  130. segdes mcoord
  131. * recherche d une nouvelle instruction
  132. segact mesins*mod
  133. INSCOU = 0
  134. 3456 CONTINUE
  135.  
  136. * write (6,*) ' ith nbins dans nouins2 ',ith,nbins
  137. IF ( NBINS .EQ. 0 ) THEN
  138. if (inass .eq. 0) then
  139. * write(6,*) 'nouins2, on ne doit pas passer la '
  140. lotesc = .false.
  141. * write (6,*) ' desactivation mesins ith ',mesins,ith
  142. segdes mestra
  143. segdes mesins*record
  144. return
  145. else
  146. if (iospi .ne. 0)
  147. & write(ioimp,*) ' il faut attendre une instruction'
  148. SEGDES MESINS*RECORD
  149. * write (6,*) ' activation mesins ith ',mesins,ith
  150. segdes mestra
  151. SEGACT MESINS*(MOD,ECR=1)
  152. segact mestra
  153. * menage a peut-etre desactive mesins le temps que mestra soit accessible
  154. SEGACT MESINS*(MOD,ECR=1)
  155. GOTO 3456
  156. endif
  157. END IF
  158. *------------
  159. 3457 continue
  160. * est on en situation d'erreur????
  161. merres = ierres
  162. segact merres
  163. LLLERR = LOSIER
  164. segdes merres
  165. ** print*, ' il y a du travail a faire, NBINS =', NBINS
  166. mescla = LISMES(1)
  167. imescl(ith) = mescla
  168. INSCOU = MESCLA
  169. NBINS = NBINS - 1
  170. IF ( NBINS .NE. 0 ) THEN
  171. do i = 1 , NBINS
  172. lismes(i) = lismes(i+1)
  173. end do
  174. END IF
  175. lismes (NBINS+1) = 0
  176. SEGDES MESINS*RECORD
  177. ** segact mescla*(mod)
  178. ** ierr=0
  179. segdes mescla
  180. ***** segact mestra
  181. segact mescla*(mod)
  182. return
  183. end
  184.  
  185.  
  186.  
  187.  
  188.  
  189.  
  190.  
  191.  
  192.  
  193.  
  194.  
  195.  

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