Télécharger la plaquette Cast3M


fr en

Télécharger appmpi.eso

Retour à la liste

Numérotation des lignes : 

appmpi

  1. C APPMPI    SOURCE    PV090527  25/03/04    21:15:02     12170          
  2. %if APPLE
  3.       subroutine dummy_mpi
  4.         entry  mpienv
  5.         entry  mpifin
  6.         entry  mpihor
  7.         entry  mpiini
  8.         entry  mpinbc
  9.         entry  mpipac
  10.         entry  mpipai
  11.         entry  mpipar
  12.         entry  mpipme
  13.         entry  mpircv
  14.         entry  mpirgc
  15.         entry  mpiupc
  16.         entry  mpiupi
  17.         entry  mpiupr
  18.         entry mpiicc
  19.         mpiErr = 1
  20.         write (6,*) 'Les appels MPI sont desactives .'
  21.         call erreur(223)
  22.         return
  23.       end
  24. %ELSE                            
  25. %IF UNIX64   
  26.       subroutine mpienv(colDes,colcom,tag,bu,bufPos)
  27.  
  28. C=======================================================================
  29. c routine mpiEnv
  30. c      Wrapper pour l'envoi de message avec MPI
  31. c      Avantage : Lieu unique pour la gestion des erreurs
  32. c                 Passage a autre chose que MPI plus aise
  33. c                 Localisation de l'include mpi.h      
  34. c
  35. C=======================================================================
  36.       include 'mpif.h'
  37. -INC COCOLL
  38.          integer inbuf(2)
  39.          integer incount
  40.          integer bufPos
  41.          integer lonBuf
  42.          integer colDes 
  43.          integer colcom
  44.          integer tag 
  45.          integer mpiErr
  46.          segment BUFFER
  47.             character*1 ffer(lonBuf)
  48.          endsegment
  49.          pointeur bu.BUFFER
  50.          lonBuf=bu.ffer(/2)
  51.          mpiErr=0
  52.          call ooosbl
  53.          call MPI_Send(bu.ffer, bufPos,mpiTyPac , colDes-1,
  54.      &                tag,colcom , mpiErr)
  55.          call oooubl
  56.          segsup bu
  57.          if(mpiErr.ne.0) call erreur(5)
  58.          return 
  59.          end
  60.  
  61.       subroutine mpifin()
  62.  
  63. C=======================================================================
  64. c routine mpifin
  65. c      Wrapper pour l'appel a MPI_Finalize
  66. c      Avantage : Lieu unique pour la gestion des erreurs
  67. c                 Passage a autre chose que MPI plus aise
  68. c                 Localisation de l'include mpi.h      
  69. c
  70. C=======================================================================
  71.       include 'mpif.h'
  72. -INC COCOLL
  73.       integer mpiErr
  74.       segment TABTOP
  75.          integer  leau(nTab)
  76.       endsegment
  77.       pointeur itab.TABTOP
  78.       mpiErr=0
  79.       call MPI_Finalize ( mpiErr )
  80.       if(mpiErr.ne.0) call erreur(5)
  81.       itab=colltopo
  82.       segact itab*mod
  83.       call libseg(itab)
  84.       segdes itab
  85.       segsup itab
  86.       colltopo = 0
  87.       return 
  88.       end
  89.  
  90.  
  91.       subroutine mpihor(valtime)
  92.  
  93. C=======================================================================
  94. c routine mpihor
  95. c      Wrapper pour l'appel a MPI_Wtime
  96. c      Avantage : Lieu unique pour la gestion des erreurs
  97. c                 Passage a autre chose que MPI plus aise
  98. c                 Localisation de l'include mpi.h      
  99. c
  100. C=======================================================================
  101.       include 'mpif.h'
  102. -INC COCOLL
  103.       real*8 valtime
  104.       valtime   = MPI_Wtime()
  105.       return 
  106.       end
  107.  
  108.  
  109.       subroutine mpiini()
  110.  
  111. C=======================================================================
  112. c routine mpinbc
  113. c      Wrapper pour l'appel a mpi_init_thread
  114. c      Avantage : Lieu unique pour la gestion des erreurs
  115. c                 Passage a autre chose que MPI plus aise
  116. c                 Localisation de l'include mpi.h      
  117. c
  118. C=======================================================================
  119.       include 'mpif.h'
  120. -INC PPARAM
  121. -INC CCOPTIO 
  122. -INC COCOLL
  123.       integer mpiErr
  124.       integer nivmpi
  125.       integer NPROC
  126.       integer IPRANK
  127.       integer ntab
  128.       integer taille 
  129. C     Numero d'identification de Castem      
  130.       integer appIDCa
  131.       segment TABTOP
  132.          integer  leau(nTab)
  133.       endsegment
  134.       pointeur itab.TABTOP
  135.  
  136.       appIdCa = idcext(1)
  137.       mpiErr=0
  138.       nivmpi =0
  139.  
  140.  
  141.       call mpi_init_thread(MPI_THREAD_MULTIPLE, nivmpi, mpiErr )
  142.       if(mpiErr.ne.0) call erreur(5)
  143.       mpicomWo = MPI_COMM_WORLD
  144.       NPROC = 0
  145.       IPRANK = 0
  146.       CALL MPI_COMM_SIZE(MPI_COMM_WORLD, NPROC, IERR)
  147.       CALL MPI_COMM_RANK(MPI_COMM_WORLD, IPRANK, IERR)
  148. C     Allocation du tableau de topologie
  149.       nTab = NPROC
  150.       segini itab
  151.  
  152.  
  153.       call MPI_Allgather( appIDCa  , 1, MPI_INTEGER8, 
  154.      &            itab.leau, 1, MPI_INTEGER8, MPI_COMM_WORLD, ierr)
  155.       colltopo=itab 
  156.       call savseg(itab)   
  157.       segdes itab
  158.       if(iimpi.ge.6) then
  159.          write(6,*) '** kk2000 : place dans le monde',IPRANK, '/ ', 
  160.      &     NPROC
  161.       endif
  162.       call MPI_COMM_SPLIT(mpicomWo, appIdCa, 0, mpicomca, mpiErr)
  163.       if(iimpi.ge.6) then
  164.          write(ioimp,*) 'Creation du communicateur propre Castem'
  165.          write(ioimp,*) 'Numero de comm',mpicomca
  166.       endif
  167.       if(mpiErr.ne.0) call erreur(5)
  168.       mpiTyFlo=MPI_REAL8
  169.       mpiTyEnt=MPI_INTEGER8
  170.       mpiTyCha=MPI_CHARACTER
  171.       mpiTyLog=MPI_LOGICAL
  172.       mpiTyPac=MPI_PACKED
  173.       if(iimpi.ge.6) then
  174.          taille = 0
  175.          call MPI_TYPE_SIZE(mpiTyFlo,taille , mpiErr)
  176.          write(ioimp,*)  'Taille de mpiTyFlo',  taille
  177.          call MPI_TYPE_SIZE(mpiTyEnt,taille , mpiErr)
  178.          write(ioimp,*)  'Taille de mpiTyEnt',  taille
  179.          call MPI_TYPE_SIZE(mpiTyCha,taille , mpiErr)
  180.          write(ioimp,*)  'Taille de mpiTyCha',  taille
  181.          call MPI_TYPE_SIZE(mpiTyLog,taille , mpiErr)
  182.          write(ioimp,*)  'Taille de mpiTyLog',  taille
  183.          call MPI_TYPE_SIZE(mpiTyPac,taille , mpiErr)
  184.          write(ioimp,*)  'Taille de mpiTyPac',  taille
  185.       endif
  186.  
  187.       nTab = idcext(1)
  188.       segini itab
  189.       call savseg(itab)   
  190.       cointeco = itab
  191.       itab.leau( idcext(1)) = mpicomca
  192.       segdes itab
  193.  
  194.       return 
  195.       end
  196.  
  197.  
  198.       subroutine mpinbc(nbc)
  199.  
  200. C=======================================================================
  201. c routine mpinbc
  202. c      Wrapper pour l'appel a MPI_Comm_size
  203. c      Avantage : Lieu unique pour la gestion des erreurs
  204. c                 Passage a autre chose que MPI plus aise
  205. c                 Localisation de l'include mpi.h      
  206. c
  207. C=======================================================================
  208.       include 'mpif.h'
  209. -INC COCOLL
  210.       integer nbc
  211.       integer mpiErr
  212.       mpiErr=0
  213.       call MPI_Comm_size ( mpicomCa, nbc, mpiErr )
  214.       if(mpiErr.ne.0) call erreur(5)
  215.       return 
  216.       end
  217.  
  218.  
  219.       subroutine mpipac(inbuf,incount,bu,bufpos)
  220. C=======================================================================
  221. c routine mpiPaC
  222. c      Wrapper pour l'appel a mpi_pack avec un tableau de caracteres en
  223. c      arguement.
  224. c      Pour OK compilation sous AIX
  225. c      Avantage : Lieu unique pour la gestion des erreurs
  226. c                 Passage a autre chose que MPI plus aise
  227. c                 Localisation de l'include mpi.h      
  228. c
  229. C=======================================================================
  230.       include 'mpif.h'
  231. -INC COCOLL
  232.       integer inbuf(2)
  233.       integer incount
  234.       integer bufPos
  235.       integer lonBuf
  236.       integer mpiErr
  237.       segment BUFFER
  238.          character*1 ffer(lonBuf)
  239.       endsegment
  240.       pointeur bu.BUFFER
  241.       lonBuf=bu.ffer(/2)
  242.       mpiErr=0
  243.       call MPI_PACK(inbuf,incount,mpiTyCha,bu.ffer,lonBuf,
  244.      &                bufPos,mpicomCa,mpiErr)
  245.       if(mpiErr.ne.0) call erreur(5)
  246. C      write(ioimp,*) 'Sortie mpipac.eso'
  247.       return 
  248.       end
  249.  
  250.  
  251.       subroutine mpipai(inbuf,incount,bu,bufpos)
  252. C=======================================================================
  253. c routine mpiPaC
  254. c      Wrapper pour l'appel a mpi_pack avec un tableau de caracteres en
  255. c      arguement.
  256. c      Pour OK compilation sous AIX
  257. c      Avantage : Lieu unique pour la gestion des erreurs
  258. c                 Passage a autre chose que MPI plus aise
  259. c                 Localisation de l'include mpi.h      
  260. c
  261. C=======================================================================
  262.       include 'mpif.h'
  263. -INC COCOLL
  264.       integer inbuf(2)
  265.       integer incount
  266.       integer bufPos
  267.       integer lonBuf
  268.       integer mpiErr
  269.       segment BUFFER
  270.          character*1 ffer(lonBuf)
  271.       endsegment
  272.       pointeur bu.BUFFER
  273.       lonBuf=bu.ffer(/2)
  274.       mpiErr=0
  275.       call MPI_PACK(inbuf,incount,mpiTyEnt,bu.ffer,lonBuf,
  276.      &                bufPos,mpicomCa,mpiErr)
  277.       if(mpiErr.ne.0) call erreur(5)
  278. c      write(ioimp,*) 'Sortie mpipai.eso'
  279.       return 
  280.       end
  281.  
  282.  
  283.       subroutine mpipar(inbuf,incount,bu,bufpos)
  284. C=======================================================================
  285. c routine mpiPaC
  286. c      Wrapper pour l'appel a mpi_pack avec un tableau de caracteres en
  287. c      arguement.
  288. c      Pour OK compilation sous AIX
  289. c      Avantage : Lieu unique pour la gestion des erreurs
  290. c                 Passage a autre chose que MPI plus aise
  291. c                 Localisation de l'include mpi.h      
  292. c
  293. C=======================================================================
  294.       include 'mpif.h'
  295. -INC COCOLL
  296.       integer inbuf(2)
  297.       integer incount
  298.       integer bufPos
  299.       integer lonBuf
  300.       integer mpiErr
  301.       segment BUFFER
  302.          character*1 ffer(lonBuf)
  303.       endsegment
  304.       pointeur bu.BUFFER
  305.       lonBuf=bu.ffer(/2)
  306.       mpiErr=0
  307.       call MPI_PACK(inbuf,incount,mpiTyFlo,bu.ffer,lonBuf,
  308.      &                bufPos,mpicomCa,mpiErr)
  309.       if(mpiErr.ne.0) call erreur(5)
  310. c      write(ioimp,*) 'Sortie mpipar.eso'
  311.       return 
  312.       end
  313.  
  314.  
  315.       subroutine mpipme(nbel,type,taille)
  316.  
  317. C=======================================================================
  318. c routine mpipme
  319. c      Wrapper pour l'appel a mpi_pack_size 
  320. c      Avantage : Lieu unique pour la gestion des erreurs
  321. c                 Passage a autre chose que MPI plus aise
  322. c                 Localisation de l'include mpi.h      
  323. c
  324. C=======================================================================
  325.       include 'mpif.h'
  326. -INC COCOLL
  327.       integer nbel
  328.       character*4 type
  329.       integer mpity
  330.       integer taille
  331.       integer mpiErr
  332.       mpity=-1
  333.       mpiErr=0
  334.       if(type .eq. 'INTE') then
  335.          mpity = mpiTyFlo
  336.       endif
  337.       if(type .eq. 'FLOT') then
  338.          mpity = mpiTyEnt
  339.       endif
  340.       if(type .eq. 'CHAR') then
  341.          mpity = mpiTyCha
  342.       endif
  343.       call MPI_PACK_SIZE(nbel, mpity, mpicomCa, taille, mpiErr)
  344.       if(mpiErr.ne.0) call erreur(5)
  345.       return 
  346.       end
  347.  
  348.  
  349.       subroutine mpircv(coldes,colcom,tag,bu)
  350.  
  351. C=======================================================================
  352. c routine mpiRcv
  353. c      Wrapper pour la recepption de message avec MPI
  354. c      Avantage : Lieu unique pour la gestion des erreurs
  355. c                 Passage a autre chose que MPI plus aise
  356. c                 Localisation de l'include mpi.h      
  357. c
  358. C=======================================================================
  359.       include 'mpif.h'
  360. -INC COCOLL
  361.       integer mpiErr
  362.       integer colcom
  363.       integer colDes 
  364.          integer tag 
  365.       integer mpi_status(MPI_STATUS_SIZE)
  366.       integer bufpos
  367.       segment BUFFER
  368.          character*1 ffer(lonBuf)
  369.       endsegment
  370.       pointeur bu.BUFFER
  371.       mpiErr=0
  372.       call ooosbl
  373.       call MPI_PROBE(colDes-1, tag, colcom, 
  374.      &                  mpi_status, mpiErr)
  375.       call oooubl
  376.       if(mpiErr.ne.0) call erreur(5)      
  377. C        Allocation du buffer 
  378.       lonBuf=0
  379.       call MPI_GET_COUNT(mpi_status, mpiTyPac,lonBuf ,mpiErr)
  380.       if(mpiErr.ne.0) call erreur(5)
  381.       segini bu
  382.       bufPos = 0
  383. C        Reception du message
  384.       call ooosbl
  385.       call MPI_RECV(bu.ffer,lonBuf,mpiTyPac,colDes-1,tag,
  386.      &            colcom, MPI_STATUS_IGNORE, mpiErr)
  387.       call oooubl
  388.  
  389.       if(mpiErr.ne.0) call erreur(5)
  390.       return 
  391.       end
  392.  
  393.  
  394.       subroutine mpirgc(rgc)
  395.  
  396. C=======================================================================
  397. c routine mpipme
  398. c      Wrapper pour l'appel a MPI_Comm_rank
  399. c      Avantage : Lieu unique pour la gestion des erreurs
  400. c                 Passage a autre chose que MPI plus aise
  401. c                 Localisation de l'include mpi.h      
  402. c
  403. C=======================================================================
  404.       include 'mpif.h'
  405. -INC COCOLL
  406.       integer rgc
  407.       integer mpiErr
  408.       mpiErr=0
  409.       call MPI_Comm_rank ( mpicomCa, rgc, mpiErr )
  410.       if(mpiErr .ne. 0) call erreur(5)
  411.       return 
  412.       end
  413.  
  414.  
  415.       subroutine mpiupc(outbuf,outcount,bu,bufpos)
  416. C=======================================================================
  417. c routine mpiupC
  418. c      Wrapper pour l'appel a mpi_unpack avec un tableau de caracteres en
  419. c      argument.
  420. c      Pour OK compilation sous AIX
  421. c      Avantage : Lieu unique pour la gestion des erreurs
  422. c                 Passage a autre chose que MPI plus aise
  423. c                 Localisation de l'include mpi.h      
  424. c
  425. C=======================================================================
  426.       include 'mpif.h'
  427. -INC COCOLL
  428.       integer outbuf(2)
  429.       integer outcount
  430.       integer bufPos
  431.       integer lonBuf
  432.       integer mpiErr
  433.       segment BUFFER
  434.          character*1 ffer(lonBuf)
  435.       endsegment
  436.       pointeur bu.BUFFER
  437.       lonBuf=bu.ffer(/2)
  438.       mpiErr=0
  439.       call MPI_UNPACK(bu.ffer, lonBuf,bufPos,outbuf,outcount
  440.      &                           ,mpiTyCha, mpicomCa, mpiErr)
  441.       if(mpiErr.ne.0) call erreur(5)
  442. c      write(ioimp,*) 'Sortie mpiupc.eso'
  443.       return 
  444.       end
  445.  
  446.  
  447.       subroutine mpiupi(outbuf,outcount,bu,bufpos)
  448. C=======================================================================
  449. c routine mpiupC
  450. c      Wrapper pour l'appel a mpi_unpack avec un tableau de caracteres en
  451. c      argument.
  452. c      Pour OK compilation sous AIX
  453. c      Avantage : Lieu unique pour la gestion des erreurs
  454. c                 Passage a autre chose que MPI plus aise
  455. c                 Localisation de l'include mpi.h      
  456. c
  457. C=======================================================================
  458.       include 'mpif.h'
  459. -INC COCOLL
  460.       integer outbuf(2)
  461.       integer outcount
  462.       integer bufPos
  463.       integer lonBuf
  464.       integer mpiErr
  465.       segment BUFFER
  466.          character*1 ffer(lonBuf)
  467.       endsegment
  468.       pointeur bu.BUFFER
  469.       lonBuf=bu.ffer(/2)
  470.       mpiErr=0
  471.       call MPI_UNPACK(bu.ffer, lonBuf,bufPos,outbuf,outcount
  472.      &                           ,mpiTyEnt, mpicomCa, mpiErr)
  473.       if(mpiErr.ne.0) call erreur(5)
  474. c      write(ioimp,*) 'Sortie mpiupi.eso'
  475.       return 
  476.       end
  477.  
  478.  
  479.       subroutine mpiupr(outbuf,outcount,bu,bufpos)
  480. C=======================================================================
  481. c routine mpiupC
  482. c      Wrapper pour l'appel a mpi_unpack avec un tableau de caracteres en
  483. c      argument.
  484. c      Pour OK compilation sous AIX
  485. c      Avantage : Lieu unique pour la gestion des erreurs
  486. c                 Passage a autre chose que MPI plus aise
  487. c                 Localisation de l'include mpi.h      
  488. c
  489. C=======================================================================
  490.       include 'mpif.h'
  491. -INC COCOLL
  492.       integer outbuf(2)
  493.       integer outcount
  494.       integer bufPos
  495.       integer lonBuf
  496.       integer mpiErr
  497.       segment BUFFER
  498.          character*1 ffer(lonBuf)
  499.       endsegment
  500.       pointeur bu.BUFFER
  501.       lonBuf=bu.ffer(/2)
  502.       mpiErr=0
  503.       call MPI_UNPACK(bu.ffer, lonBuf,bufPos,outbuf,outcount
  504.      &                           ,mpiTyFlo, mpicomCa, mpiErr)
  505.       if(mpiErr.ne.0) call erreur(5)
  506. c      write(ioimp,*) 'Sortie mpiupr.eso'
  507.       return 
  508.       end
  509.       subroutine mpiicc(alead,blead,itag,interco)
  510.  
  511. C=======================================================================
  512. c routine mpiicc
  513. c      Wrapper pour l'appel a MPI_Intercomm_create
  514. c      Avantage : Lieu unique pour la gestion des erreurs
  515. c                 Passage a autre chose que MPI plus aise
  516. c                 Localisation de l'include mpi.h      
  517. c
  518. C=======================================================================
  519.       include 'mpif.h'
  520. -INC PPARAM
  521. -INC CCOPTIO 
  522. -INC COCOLL
  523.       integer mpiErr
  524.       integer itag
  525.       integer alead
  526.       integer blead
  527.       integer interco
  528.       alead = 0
  529.       interco = 0
  530.       ierr = 0
  531.       mpiErr = 0
  532.  
  533.       CALL MPI_Intercomm_create(mpicomca, alead, 
  534.      &                 mpiComWo, blead, itag, interco,mpiErr)
  535.  
  536.       if(mpiErr.ne.0) call erreur(5)
  537.       if(iimpi.ge.6) then
  538.          write(ioimp,*) 'Intercommunicateur cree'
  539.          write(ioimp,*) 'Numero de comm', interco
  540.       endif
  541.  
  542.       return 
  543.       end
  544. %ELSE
  545.       subroutine dummy_mpi
  546.         entry  mpienv
  547.         entry  mpifin
  548.         entry  mpihor
  549.         entry  mpiini
  550.         entry  mpinbc
  551.         entry  mpipac
  552.         entry  mpipai
  553.         entry  mpipar
  554.         entry  mpipme
  555.         entry  mpircv
  556.         entry  mpirgc
  557.         entry  mpiupc
  558.         entry  mpiupi
  559.         entry  mpiupr
  560.         entry mpiicc
  561.         mpiErr = 1
  562.         write (6,*) 'Les appels MPI sont desactives .'
  563.         call erreur(223)
  564.         return
  565.       end
  566.  
  567. %ENDIF
  568. %ENDIF 
  569.  
  570.  
  571.  
  572.  
  573.  

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