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/02/26    21:15:02     11850          
  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. *  boucle jusqu'a un rc
  224. **      iend=text(/1)
  225.         iend=LOCHAI
  226.         call lires(text(1:LOCHAI),iend,istat,ith)
  227.         if (iend.le.0) goto 50
  228. *  virer les retours chariots
  229.         do i = 1, iend
  230.           if (text(i:i).eq.char(10)) text(i:i)=' '
  231.           if (text(i:i).eq.char(13)) text(i:i)=' '
  232.         enddo
  233.         text(iend+1:LOCHAI)=' '
  234.         lgval = LONG(text)
  235. c#dbg      write(ioimp,*) '==>'//text(1:lgval)//'<==',lgval,iend
  236.         if (lgval.eq.0) goto 10
  237.  
  238.         idval = 1
  239.  20     CONTINUE
  240.           ifval = lgval
  241. *  Recherche espace (' ') comme separateur
  242.           ind = INDEX(text(idval:ifval),' ')
  243.           IF (ind.NE.0) ifval = idval + ind - 2
  244. *  Cas particulier ou 2 espaces se suivent
  245.           IF (ind.EQ.1) GOTO 21
  246.  
  247.           icour  = ifval
  248.           ifinan = ifval+1
  249.           nran   = idval-1
  250.           call redlec(sredle)
  251.           if (ierr.ne.0) goto 999
  252.           if (ire.eq.0) goto 21
  253.           ipot=mlotab+1
  254.           if (ipot.gt.mtabti(/2)) then
  255.             m=mtabti(/2)+256
  256.             segadj mtable
  257.           endif
  258.           ncas=ncar
  259.           motbuf(1:ncas)=mot(1:ncas)
  260. c#dbg      write(ioimp,*) '==>'//motbuf(1:ncas)//'<==',ire,ncas
  261.           ncas=ifval-idval+1
  262.           motbuf(1:ncas)=text(idval:ifval)
  263. c#dbg      write(ioimp,*) '==>'//motbuf(1:ncas)//'<==',ire,ncas
  264.           if (ire.eq.1) then
  265. *            call ecctab(mtable,'ENTIER  ',ipot,r_z,' ',bid,i_z,
  266. *     >                         'ENTIER  ',nfix,r_z,' ',bid,i_z)
  267.             mlotab=ipot
  268.             mtabti(mlotab)='ENTIER'
  269.             mtabii(mlotab)=mlotab
  270.             mtabtv(mlotab)='ENTIER'
  271.             mtabiv(mlotab)=nfix
  272.           elseif (ire.eq.2) then
  273. *            call ecctab(mtable,'ENTIER  ',ipot,r_z ,' ',bid,i_z,
  274. *     >                         'FLOTTANT',i_z ,flot,' ',bid,i_z)
  275.             mlotab=ipot
  276.             mtabti(mlotab)='ENTIER'
  277.             mtabii(mlotab)=mlotab
  278.             mtabtv(mlotab)='FLOTTANT'
  279.             rmtabv(mlotab)=flot
  280.           elseif (ire.eq.3 .or. ire.eq.4) then
  281.             call ecctab(mtable,
  282.      >                    'ENTIER  ',ipot,r_z,' '           ,bid,i_z,
  283.      >                    'MOT     ',i_z ,r_z,motbuf(1:ncas),bid,i_z)
  284.             segact mtable*mod
  285.           elseif (ire.eq.5) then
  286.             bid=bool
  287.             call ecctab(mtable,'ENTIER  ',ipot,r_z,' ',bid,i_z,
  288.      >                         'LOGIQUE ',i_z ,r_z,' ',bid,i_z)
  289.             segact mtable*mod
  290.           elseif (ire.eq.6) then
  291.             call ecctab(mtable,
  292.      >                    'ENTIER  ',ipot,r_z,' '           ,bid,i_z,
  293.      >                    'MOT     ',i_z ,r_z,motbuf(1:ncas),bid,i_z)
  294.             segact mtable*mod
  295.           else
  296.           endif
  297.           if (ierr.ne.0) goto 999
  298. * Il faut sauter le separateur
  299.  21       CONTINUE
  300.           idval = ifval + 2
  301. * Fin de la chaine text atteinte ?
  302.           IF (idval.GT.lgval) GOTO 10
  303.         GOTO 20
  304.       GOTO 10
  305.  
  306.  50   CONTINUE
  307. * En fin de traitement de la commande et de la recuperation de tous 
  308. * les resultats,on doit avoir istat = 0 !
  309.       if (istat.ne.0) then
  310.         interr(1)=istat
  311.         l=long(lacomm)
  312.         if (l.gt.128) then
  313.           moterr=lacomm(1:125)//'...'
  314.         else
  315.           moterr=lacomm(1:l)
  316.         end if
  317.         call erreur(873)
  318.         goto 999
  319.       end if
  320.  
  321. * Ecriture de la table resultat
  322.       call ecrobj('TABLE   ',mtable)
  323.  
  324.  999  continue
  325.       segdes,mtable
  326.       segsup,sredle
  327.  
  328. c      return
  329.       end
  330.  
  331.  
  332.  
  333.  

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