Télécharger nouins2.eso

Retour à la liste

Numérotation des lignes :

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

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