Télécharger la plaquette Cast3M


fr en

Télécharger extern.eso

Retour à la liste

Numérotation des lignes : 

extern

  1. C EXTERN    SOURCE    PV090527  24/07/31    18:12:35     11969          
  2. C  interface vers un programme exterieur
  3.  
  4.       subroutine extern
  5.  
  6.       IMPLICIT INTEGER(I-N)
  7.       IMPLICIT REAL*8 (A-H,O-Z)
  8.  
  9. -INC PPARAM
  10. -INC CCOPTIO
  11. -INC CCREDLE
  12. -INC SMTABLE
  13. -INC SMLREEL
  14. -INC SMLENTI
  15.  
  16.       external long
  17.       segment sbuff
  18.         character*(lbuf) buff
  19.       endsegment
  20.       logical bid
  21.       character*(LOCHAI) lacomm,motbuf
  22.       character*(8)      icha
  23.  
  24.       bid = .true.
  25.       i_z = 0
  26.       r_z = 0.D0
  27.  
  28.       ith=0
  29.       ith=oothrd
  30.  
  31.       call lircha(lacomm,1,iretou)
  32.       if (ierr.ne.0) return
  33.       l=long(lacomm)
  34. c#dbg      write(ioimp,*) 'La commande "'//lacomm(1:l)//'"'
  35.  
  36.       call lance (lacomm(1:l)//char(0),ith)
  37.  
  38. *  ecriture des donnees
  39.       lbuf=1000
  40.       segini sbuff
  41.  
  42.       lpos=0
  43. * Boucle sur les donnees eventuelles de la commande :
  44.  100  CONTINUE
  45.         icha='        '
  46.         call quetyp(icha,0,iretou)
  47.         if (ierr.ne.0) return
  48.         if (iretou.eq.0) goto 200
  49. c#dbg        write(ioimp,*) 'objet lu de type :',icha
  50.         if (icha.eq.'TABLE   ') then
  51.           call lirobj(icha,mtable,1,iretou)
  52.           if (ierr.ne.0) return
  53.           segact mtable
  54.           DO 120 ipot = 1, mlotab
  55.             do 130 ipou = 1, mlotab
  56.               if (mtabti(ipou).ne.'ENTIER  ') goto 130
  57.               if (mtabii(ipou).ne.ipot) goto 130
  58.               goto 140
  59.  130        continue
  60.             goto 120
  61.  140        continue
  62.             icha=mtabtv(ipou)
  63.             if (icha.eq.'ENTIER  ') then
  64.               ient=mtabiv(ipou)
  65.               l_z=lpos+11
  66.               if (l_z.gt.lbuf) then
  67.                 lbuf=lbuf+l_z
  68.                 segadj sbuff
  69.               endif
  70.               write(buff(lpos+1:l_z),fmt=501) ient
  71.               lpos=l_z
  72.             elseif (icha.eq.'FLOTTANT') then
  73.               xv=rmtabv(ipou)
  74.               l_z=lpos+22
  75.               if (l_z.gt.lbuf) then
  76.                 lbuf=lbuf+l_z
  77.                 segadj sbuff
  78.               endif
  79.               write(buff(lpos+1:l_z),fmt=502) xv
  80.               lpos=l_z
  81.             elseif (icha.eq.'LISTENTI') then
  82.               mlenti=mtabiv(ipou)
  83.               segact mlenti
  84.               llect=lect(/1)
  85.               l_z = lpos+11*llect
  86.               if (l_z.gt.lbuf) then
  87.                 lbuf=lbuf+l_z
  88.                 segadj sbuff
  89.               endif
  90.               write(buff(lpos+1:l_z),fmt=503) (lect(jg),jg=1,llect)
  91.               segdes mlenti
  92.               lpos=l_z
  93.             elseif (icha.eq.'LISTREEL') then
  94.               mlreel=mtabiv(ipou)
  95.               segact mlreel
  96.               lprog=prog(/1)
  97.               l_z = lpos+22*lprog
  98.               if (l_z.gt.lbuf) then
  99.                 lbuf=lbuf+l_z
  100.                 segadj sbuff
  101.               endif
  102.               write(buff(lpos+1:l_z),fmt=504) (prog(jg),jg=1,lprog)
  103.               segdes mlreel
  104.               lpos = l_z
  105.             elseif (icha.eq.'MOT     ') then
  106.               motbuf = ' '
  107.               call acctab(mtable,'ENTIER  ',ipot,r_z,'    ',bid,0,
  108.      &                           'MOT     ',i_z ,r_z,motbuf,bid,i_z)
  109.               if (ierr.ne.0) return
  110.               segact mtable
  111.               lcom=long(motbuf)
  112.               if (motbuf(1:lcom).eq.'RC') then
  113.                 motbuf(1:1)=char(10)
  114.                 lcom=1
  115.               endif
  116.               l_z = lpos+lcom+1
  117.               if (l_z.gt.lbuf) then
  118.                 lbuf=lbuf+l_z
  119.                 segadj sbuff
  120.               endif
  121.               buff(lpos+1:l_z)=motbuf(1:lcom)//' '
  122.               lpos = l_z
  123.             endif
  124.  120      CONTINUE
  125.           segdes mtable
  126.         elseif (icha.eq.'ENTIER  ') then
  127.           call lirent(ient,1,iretou)
  128.           if (ierr.ne.0) return
  129.           l_z=lpos+11
  130.           if (l_z.gt.lbuf) then
  131.             lbuf=lbuf+l_z
  132.             segadj sbuff
  133.           endif
  134.           write(buff(lpos+1:l_z),fmt=501) ient
  135.           lpos=l_z
  136.         elseif (icha.eq.'FLOTTANT') then
  137.           call lirree(xv,1,iretou)
  138.           if (ierr.ne.0) return
  139.           l_z=lpos+22
  140.           if (l_z.gt.lbuf) then
  141.             lbuf=lbuf+l_z
  142.             segadj sbuff
  143.           endif
  144.           write(buff(lpos+1:l_z),fmt=502) xv
  145.           lpos=l_z
  146.           goto 100
  147.         elseif (icha.eq.'LISTENTI') then
  148.           call lirobj(icha,mlenti,1,iretou)
  149.           if (ierr.ne.0) return
  150.           segact mlenti
  151.           llect=lect(/1)
  152.           l_z = lpos+11*llect
  153.           if (l_z.gt.lbuf) then
  154.             lbuf=lbuf+l_z
  155.             segadj sbuff
  156.           endif
  157.           write(buff(lpos+1:l_z),fmt=503) (lect(jg),jg=1,llect)
  158.           segdes mlenti
  159.           lpos=l_z
  160.         elseif (icha.eq.'LISTREEL') then
  161.           call lirobj(icha,mlreel,1,iretou)
  162.           if (ierr.ne.0) return
  163.           segact mlreel
  164.           lprog=prog(/1)
  165.           l_z = lpos+22*lprog
  166.           if (l_z.gt.lbuf) then
  167.             lbuf=lbuf+l_z
  168.             segadj sbuff
  169.           endif
  170.           write(buff(lpos+1:l_z),fmt=504) (prog(jg),jg=1,lprog)
  171.           segdes mlreel
  172.           lpos = l_z
  173.         elseif (icha.eq.'MOT     ') then
  174.           motbuf = ' '
  175.           call lircha(motbuf,1,iretou)
  176.           if (ierr.ne.0) return
  177.           lcom=long(motbuf)
  178.           if (motbuf(1:lcom).eq.'RC') then
  179.             motbuf(1:1)=char(10)
  180.             lcom=1
  181.           endif
  182.           l_z = lpos+lcom+1
  183.           if (l_z.gt.lbuf) then
  184.             lbuf=lbuf+l_z
  185.             segadj sbuff
  186.           endif
  187.           buff(lpos+1:l_z)=motbuf(1:lcom)//' '
  188.           lpos = l_z
  189.         else
  190.           write(ioimp,*) 'Objet '//icha//' non traite a ce jour'
  191.         endif
  192.       GOTO 100
  193.  200  continue
  194.       if (lpos+1.gt.lbuf) then
  195.         lbuf=lbuf+LOCHAI
  196.         segadj sbuff
  197.       endif
  198.       lpos=lpos+1
  199.       buff(lpos:lpos)=char(10)
  200. %IF WIN32,WIN64
  201.       call ecrdon(buff,lpos,ith)
  202. %ELSE
  203.       if (lpos .gt. 1) call ecrdon(buff,lpos,ith)
  204. %ENDIF
  205. c#dbg      write(ioimp,*) '=>'//buff(1:lpos)//'<=',lpos
  206.       segsup sbuff
  207.  
  208. C Les formats d'ecriture des donnees (ajout systematique d'un espace)
  209.  501  FORMAT(i10,1x)
  210.  502  FORMAT(e21.15,1x)
  211. C!! 502  FORMAT(d21.15,1x)
  212.  503  FORMAT(2000000000(i10,1x))
  213.  504  FORMAT(2000000000(e21.15,1x))
  214. C!! 504  FORMAT(2000000000(d21.15,1x))
  215.  
  216. *  creation du resultat
  217.       m=100
  218.       segini mtable
  219.       mlotab=0
  220.       call inired(sredle)
  221.       separa=.false.
  222.  10   CONTINUE
  223.       istart=1
  224.  11   CONTINUE
  225. *  boucle jusqu'a un rc
  226.         iend=LOCHAI-istart+1
  227.         if (iend.le.0) goto 12
  228.         call lires(text(istart:LOCHAI),iend,istat,ith)
  229.         iend=istart-1+iend
  230.         if (iend.gt.0.and.ichar(text(iend:iend)).ne.10) then
  231. **       write(6,*) 'ichar ',ichar(text(iend:iend))
  232. **       write(6,*) 'istart iend ',istart,iend
  233.          istart=iend+1
  234.          goto 11
  235.         endif
  236.  
  237.         if (iend.lt.istart) goto 50
  238.  12   CONTINUE
  239. *  virer les retours chariots
  240.         do i = 1, iend
  241.           if (text(i:i).eq.char(10)) text(i:i)=' '
  242.           if (text(i:i).eq.char(13)) text(i:i)=' '
  243.         enddo
  244.         text(iend+1:LOCHAI)=' '
  245.         lgval = LONG(text)
  246. **         write(ioimp,*) '==>'//text(1:lgval)//'<==',lgval,iend
  247.         if (lgval.eq.0) goto 10
  248.  
  249.         idval = 1
  250.  20     CONTINUE
  251.           ifval = lgval
  252. *  Recherche espace (' ') comme separateur
  253.           ind = INDEX(text(idval:ifval),' ')
  254.           IF (ind.NE.0) ifval = idval + ind - 2
  255. *  Cas particulier ou 2 espaces se suivent
  256.           IF (ind.EQ.1) GOTO 21
  257.  
  258.           icour  = ifval
  259.           ifinan = ifval+1
  260.           nran   = idval-1
  261.           call redlec(sredle)
  262.           if (ierr.ne.0) goto 999
  263.           if (ire.eq.0) goto 21
  264.           ipot=mlotab+1
  265.           if (ipot.gt.mtabti(/2)) then
  266.             m=mtabti(/2)+256
  267.             segadj mtable
  268.           endif
  269.           ncas=ncar
  270.           motbuf(1:ncas)=mot(1:ncas)
  271. **         write(ioimp,*) '==>'//motbuf(1:ncas)//'<==',ire,ncas
  272.           ncas=ifval-idval+1
  273.           motbuf(1:ncas)=text(idval:ifval)
  274. **         write(ioimp,*) '==>'//motbuf(1:ncas)//'<==',ire,ncas
  275.           if (ire.eq.1) then
  276. *            call ecctab(mtable,'ENTIER  ',ipot,r_z,' ',bid,i_z,
  277. *     >                         'ENTIER  ',nfix,r_z,' ',bid,i_z)
  278.             mlotab=ipot
  279.             mtabti(mlotab)='ENTIER'
  280.             mtabii(mlotab)=mlotab
  281.             mtabtv(mlotab)='ENTIER'
  282.             mtabiv(mlotab)=nfix
  283.           elseif (ire.eq.2) then
  284. *            call ecctab(mtable,'ENTIER  ',ipot,r_z ,' ',bid,i_z,
  285. *     >                         'FLOTTANT',i_z ,flot,' ',bid,i_z)
  286.             mlotab=ipot
  287.             mtabti(mlotab)='ENTIER'
  288.             mtabii(mlotab)=mlotab
  289.             mtabtv(mlotab)='FLOTTANT'
  290.             rmtabv(mlotab)=flot
  291.           elseif (ire.eq.3 .or. ire.eq.4) then
  292.             call ecctab(mtable,
  293.      >                    'ENTIER  ',ipot,r_z,' '           ,bid,i_z,
  294.      >                    'MOT     ',i_z ,r_z,motbuf(1:ncas),bid,i_z)
  295.             segact mtable*mod
  296.           elseif (ire.eq.5) then
  297.             bid=bool
  298.             call ecctab(mtable,'ENTIER  ',ipot,r_z,' ',bid,i_z,
  299.      >                         'LOGIQUE ',i_z ,r_z,' ',bid,i_z)
  300.             segact mtable*mod
  301.           elseif (ire.eq.6) then
  302.             call ecctab(mtable,
  303.      >                    'ENTIER  ',ipot,r_z,' '           ,bid,i_z,
  304.      >                    'MOT     ',i_z ,r_z,motbuf(1:ncas),bid,i_z)
  305.             segact mtable*mod
  306.           else
  307.           endif
  308.           if (ierr.ne.0) goto 999
  309. * Il faut sauter le separateur
  310.  21       CONTINUE
  311.           idval = ifval + 2
  312. * Fin de la chaine text atteinte ?
  313.           IF (idval.GT.lgval) GOTO 10
  314.         GOTO 20
  315.       GOTO 10
  316.  
  317.  50   CONTINUE
  318. * En fin de traitement de la commande et de la recuperation de tous 
  319. * les resultats,on doit avoir istat = 0 !
  320.       if (istat.ne.0) then
  321.         interr(1)=istat
  322.         l=long(lacomm)
  323.         if (l.gt.128) then
  324.           moterr=lacomm(1:125)//'...'
  325.         else
  326.           moterr=lacomm(1:l)
  327.         end if
  328.         call erreur(873)
  329.         goto 999
  330.       end if
  331.  
  332. * Ecriture de la table resultat
  333.       call ecrobj('TABLE   ',mtable)
  334.  
  335.  999  continue
  336.       segdes,mtable
  337.       segsup,sredle
  338.  
  339. c      return
  340.       end
  341.  
  342.  
  343.  
  344.  
  345.  

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