OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
spmd_sms.F File Reference
#include "implicit_f.inc"
#include "com01_c.inc"
#include "parit_c.inc"
#include "sms_c.inc"
#include "com04_c.inc"
#include "spmd.inc"
#include "task_c.inc"
#include "param_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine spmd_sort_sms (iskyi_sms, mskyi_sms, fr_sms)
subroutine ams_prepare_poff_assembly (iad_elem, fr_elem, nb_fr, fr_loc, iad_i2m, fr_i2m, nb_fri2m, fr_loc_i2m)
subroutine spmd_nlist_sms (fr_sms, fr_rms)
subroutine spmd_list_sms (iskyi_sms, fr_sms, fr_rms, list_sms, list_rms, npby, tagslv_rby_sms)
subroutine spmd_mij_sms (iskyi_sms, fr_sms, fr_rms, list_rms, mskyi_sms, mij_sms)
subroutine spmd_glob_lmin (lmin, imin)
subroutine spmd_glob_lmax (lmax, imax)
subroutine spmd_nndft_sms (fr_sms, fr_rms, list_sms, list_rms, iad_elem, fr_elem, nndft0, nndft1, isortnd)
subroutine spmd_nnz_sms (fr_sms, fr_rms, list_sms, list_rms, iad_elem, fr_elem, nnzm, iadk, kadm)
subroutine spmd_exchm_sms (fr_sms, fr_rms, list_sms, list_rms, iad_elem, fr_elem, iadk, jdik, lt_k, kadm, jdim, lt_m, invnd)
subroutine spmd_exch_awork (a, iad_elem, fr_elem, size, lenr)
subroutine spmd_exch_rbe3_nodnx (nodnx_sms, fr_m, iad_m, lcomm)

Function/Subroutine Documentation

◆ ams_prepare_poff_assembly()

subroutine ams_prepare_poff_assembly ( integer, dimension(2,*) iad_elem,
integer, dimension(*) fr_elem,
integer nb_fr,
integer, dimension(*) fr_loc,
integer, dimension(*) iad_i2m,
integer, dimension(*) fr_i2m,
integer nb_fri2m,
integer, dimension(*) fr_loc_i2m )

Definition at line 114 of file spmd_sms.F.

116C-----------------------------------------------
117C I m p l i c i t T y p e s
118C-----------------------------------------------
119 USE spmd_comm_world_mod, ONLY : spmd_comm_world
120#include "implicit_f.inc"
121C-----------------------------------------------
122C C o m m o n B l o c k s
123C-----------------------------------------------
124#include "com01_c.inc"
125#include "com04_c.inc"
126C-----------------------------------------------
127C D u m m y A r g u m e n t s
128C-----------------------------------------------
129 INTEGER IAD_ELEM(2,*),FR_ELEM(*),FR_LOC(*),NB_FR,
130 * IAD_I2M(*),FR_I2M(*),NB_FRI2M, FR_LOC_I2M(*)
131C-----------------------------------------------
132C L o c a l V a r i a b l e s
133C-----------------------------------------------
134 INTEGER P,J,NOD
135 INTEGER, DIMENSION(:), ALLOCATABLE :: TAG
136
137 ALLOCATE(tag(numnod))
138 tag(1:numnod)=0
139
140 DO p=1,nspmd
141 DO j=iad_elem(1,p),iad_elem(1,p+1)-1
142 nod = fr_elem(j)
143 tag(nod)=1
144 ENDDO
145 ENDDO
146
147 nb_fr=0
148 DO j=1,numnod
149 IF(tag(j)==1) THEN
150 nb_fr=nb_fr+1
151 fr_loc(nb_fr)=j
152 ENDIF
153 ENDDO
154
155C Interface type2
156 tag(1:numnod)=0
157 DO j=iad_i2m(1),iad_i2m(nspmd+1)-1
158 nod = fr_i2m(j)
159 tag(nod)=1
160 ENDDO
161
162 nb_fri2m=0
163 DO j=1,numnod
164 IF(tag(j)==1) THEN
165 nb_fri2m=nb_fri2m+1
166 fr_loc_i2m(nb_fri2m)=j
167 ENDIF
168 ENDDO
169
170
171
172 RETURN

◆ spmd_exch_awork()

subroutine spmd_exch_awork ( a,
integer, dimension(2,*) iad_elem,
integer, dimension(*) fr_elem,
integer size,
integer lenr )

Definition at line 1128 of file spmd_sms.F.

1130C-----------------------------------------------
1131C I m p l i c i t T y p e s
1132C-----------------------------------------------
1133 USE spmd_comm_world_mod, ONLY : spmd_comm_world
1134#include "implicit_f.inc"
1135C-----------------------------------------------------------------
1136C M e s s a g e P a s s i n g
1137C-----------------------------------------------
1138#include "spmd.inc"
1139C-----------------------------------------------
1140C C o m m o n B l o c k s
1141C-----------------------------------------------
1142#include "com01_c.inc"
1143#include "task_c.inc"
1144C-----------------------------------------------
1145C D u m m y A r g u m e n t s
1146C-----------------------------------------------
1147 INTEGER IAD_ELEM(2,*),FR_ELEM(*), SIZE, LENR
1148 my_real
1149 . a(3,*)
1150#ifdef MPI
1151C-----------------------------------------------
1152C L o c a l V a r i a b l e s
1153C-----------------------------------------------
1154 INTEGER MSGTYP,I,NOD,LOC_PROC,IERROR,MSGOFF,
1155 . SIZ,J,K,L,NB_NOD,
1156 . STATUS(MPI_STATUS_SIZE),
1157 . IAD_SEND(NSPMD+1),IAD_RECV(NSPMD+1),
1158 . REQ_R(NSPMD),REQ_S(NSPMD)
1159 DATA msgoff/17000/
1160
1161 my_real
1162 . rbuf(size*lenr ),
1163 . sbuf(size*lenr )
1164C-----------------------------------------------
1165C S o u r c e L i n e s
1166C-----------------------------------------------
1167 loc_proc = ispmd + 1
1168 l = 1
1169 iad_recv(1) = 1
1170 DO i=1,nspmd
1171 siz = size*(iad_elem(1,i+1)-iad_elem(1,i))
1172 IF(siz/=0)THEN
1173 msgtyp = msgoff
1174 CALL mpi_irecv(
1175 s rbuf(l),siz,real,it_spmd(i),msgtyp,
1176 g spmd_comm_world,req_r(i),ierror)
1177 l = l + siz
1178 ENDIF
1179 iad_recv(i+1) = l
1180 END DO
1181 l = 1
1182 iad_send(1) = 1
1183 DO i=1,nspmd
1184C preparation envoi partie fixe (elem) a proc I
1185#include "vectorize.inc"
1186 DO j=iad_elem(1,i),iad_elem(1,i+1)-1
1187 nod = fr_elem(j)
1188 sbuf(l ) = a(1,nod)
1189 sbuf(l+1) = a(2,nod)
1190 sbuf(l+2) = a(3,nod)
1191 l = l + SIZE
1192 END DO
1193C
1194 iad_send(i+1) = l
1195 ENDDO
1196C
1197C echange messages
1198C
1199 DO i=1,nspmd
1200C--------------------------------------------------------------------
1201C envoi a N+I mod P
1202C test si msg necessaire a envoyer a completer par test interface
1203 IF(iad_elem(1,i+1)-iad_elem(1,i)>0)THEN
1204 msgtyp = msgoff
1205 siz = iad_send(i+1)-iad_send(i)
1206 l = iad_send(i)
1207 CALL mpi_isend(
1208 s sbuf(l),siz,real,it_spmd(i),msgtyp,
1209 g spmd_comm_world,req_s(i),ierror)
1210 ENDIF
1211C--------------------------------------------------------------------
1212 ENDDO
1213C
1214C decompactage
1215C
1216 DO i = 1, nspmd
1217C test si msg necessaire a envoyer a completer par test interface
1218 nb_nod = iad_elem(1,i+1)-iad_elem(1,i)
1219 IF(nb_nod>0)THEN
1220 CALL mpi_wait(req_r(i),status,ierror)
1221 l = iad_recv(i)
1222#include "vectorize.inc"
1223 DO j=iad_elem(1,i),iad_elem(1,i+1)-1
1224 nod = fr_elem(j)
1225 a(1,nod) = a(1,nod) + rbuf(l)
1226 a(2,nod) = a(2,nod) + rbuf(l+1)
1227 a(3,nod) = a(3,nod) + rbuf(l+2)
1228 l = l + SIZE
1229 END DO
1230C ---
1231 ENDIF
1232 END DO
1233C
1234C wait terminaison isend
1235C
1236 DO i = 1, nspmd
1237 IF(iad_elem(1,i+1)-iad_elem(1,i)>0)THEN
1238 CALL mpi_wait(req_s(i),status,ierror)
1239 ENDIF
1240 ENDDO
1241C
1242#endif
1243 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
mpi_isend
subroutine mpi_isend(buf, cnt, datatype, dest, tag, comm, ireq, ierr)
Definition mpi.f:382
mpi_wait
subroutine mpi_wait(ireq, status, ierr)
Definition mpi.f:525
mpi_irecv
subroutine mpi_irecv(buf, cnt, datatype, source, tag, comm, ireq, ierr)
Definition mpi.f:372

◆ spmd_exch_rbe3_nodnx()

subroutine spmd_exch_rbe3_nodnx ( integer, dimension(*) nodnx_sms,
integer, dimension(*) fr_m,
integer, dimension(*) iad_m,
integer lcomm )

Definition at line 1254 of file spmd_sms.F.

1256C-----------------------------------------------
1257C I m p l i c i t T y p e s
1258C-----------------------------------------------
1259 USE spmd_comm_world_mod, ONLY : spmd_comm_world
1260#include "implicit_f.inc"
1261C-----------------------------------------------
1262C M e s s a g e P a s s i n g
1263C-----------------------------------------------
1264#include "spmd.inc"
1265C-----------------------------------------------
1266C C o m m o n B l o c k s
1267C-----------------------------------------------
1268#include "com01_c.inc"
1269#include "task_c.inc"
1270C-----------------------------------------------
1271C D u m m y A r g u m e n t s
1272C-----------------------------------------------
1273 INTEGER LCOMM, FR_M(*), IAD_M(*), NODNX_SMS(*)
1274#ifdef MPI
1275C-----------------------------------------------
1276C L o c a l V a r i a b l e s
1277C-----------------------------------------------
1278 INTEGER MSGTYP,LOC_PROC,NOD,I,J,L,IDEB,IAD,LEN,
1279 . NBINDEX,INDEX,MSGOFF,SIZ,IERROR,K,
1280 . STATUS(MPI_STATUS_SIZE),ISIZE6,
1281 . REQ_S(NSPMD),REQ_R(NSPMD),INDEXI(NSPMD)
1282 DATA msgoff/17001/
1283 INTEGER SBUF(LCOMM), RBUF(LCOMM)
1284C-----------------------------------------------
1285C S o u r c e L i n e s
1286C-----------------------------------------------
1287 loc_proc = ispmd + 1
1288C
1289 ideb = 1
1290 l = 0
1291 DO i = 1, nspmd
1292 siz = iad_m(i+1)-iad_m(i)
1293 IF(siz>0) THEN
1294 l=l+1
1295 indexi(l)=i
1296 msgtyp = msgoff
1297 CALL mpi_irecv(
1298 s rbuf(ideb),siz,mpi_integer,it_spmd(i),msgtyp,
1299 g spmd_comm_world,req_r(l),ierror)
1300 ideb = ideb + siz
1301 ENDIF
1302 ENDDO
1303 nbindex = l
1304C
1305 ideb = 1
1306 DO l = 1, nbindex
1307 i = indexi(l)
1308 len = iad_m(i+1) - iad_m(i)
1309 iad = iad_m(i)-1
1310#include "vectorize.inc"
1311 DO j = 1, len
1312 nod = fr_m(iad+j)
1313 sbuf(ideb) = nodnx_sms(nod)
1314 ideb = ideb + 1
1315 ENDDO
1316 ENDDO
1317C
1318 ideb = 1
1319 DO l=1,nbindex
1320 i = indexi(l)
1321 siz = iad_m(i+1)-iad_m(i)
1322 msgtyp = msgoff
1323 CALL mpi_isend(
1324 s sbuf(ideb),siz,mpi_integer,it_spmd(i),msgtyp,
1325 g spmd_comm_world,req_s(l),ierror)
1326 ideb = ideb + siz
1327 ENDDO
1328C
1329 DO l=1,nbindex
1330 CALL mpi_waitany(nbindex,req_r,index,status,ierror)
1331 i = indexi(index)
1332 ideb = 1+(iad_m(i)-1)
1333 len = iad_m(i+1)-iad_m(i)
1334 iad = iad_m(i)-1
1335#include "vectorize.inc"
1336 DO j = 1, len
1337 nod = fr_m(iad+j)
1338 nodnx_sms(nod)=nodnx_sms(nod)+rbuf(j)
1339 ideb = ideb + 1
1340 ENDDO
1341 ENDDO
1342C
1343 DO l=1,nbindex
1344 CALL mpi_waitany(nbindex,req_s,index,status,ierror)
1345 ENDDO
1346C
1347 RETURN
1348#endif
mpi_waitany
subroutine mpi_waitany(cnt, array_of_requests, index, status, ierr)
Definition mpi.f:549

◆ spmd_exchm_sms()

subroutine spmd_exchm_sms ( integer, dimension(nspmd+1) fr_sms,
integer, dimension(nspmd+1) fr_rms,
integer, dimension(*) list_sms,
integer, dimension(*) list_rms,
integer, dimension(2,*) iad_elem,
integer, dimension(*) fr_elem,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
lt_k,
integer, dimension(*) kadm,
integer, dimension(*) jdim,
lt_m,
integer, dimension(*) invnd )

Definition at line 920 of file spmd_sms.F.

924C-----------------------------------------------
925C M o d u l e s
926C-----------------------------------------------
927 USE message_mod
928C-----------------------------------------------
929C I m p l i c i t T y p e s
930C-----------------------------------------------
931 USE spmd_comm_world_mod, ONLY : spmd_comm_world
932#include "implicit_f.inc"
933C-----------------------------------------------
934C M e s s a g e P a s s i n g
935C-----------------------------------------------
936#include "spmd.inc"
937C-----------------------------------------------
938C C o m m o n B l o c k s
939C-----------------------------------------------
940#include "com01_c.inc"
941#include "com04_c.inc"
942#include "task_c.inc"
943C-----------------------------------------------
944C D u m m y A r g u m e n t s
945C-----------------------------------------------
946 INTEGER FR_SMS(NSPMD+1), FR_RMS(NSPMD+1),
947 . LIST_SMS(*), LIST_RMS(*), IAD_ELEM(2,*), FR_ELEM(*),
948 . IADK(*), JDIK(*), KADM(*), JDIM(*), INVND(*)
949 my_real
950 . lt_k(*), lt_m(*)
951#ifdef MPI
952C-----------------------------------------------
953C L o c a l V a r i a b l e s
954C-----------------------------------------------
955 INTEGER MSGTYP,I,LOC_PROC,IERROR,
956 . SIZ,J,K,L,M,N,NOD,P,LL,
957 . SIZS(NSPMD),SIZR(NSPMD),
958 . STATUS(MPI_STATUS_SIZE),
959 . REQ_R(NSPMD), REQ_S(NSPMD), REQ_S2(NSPMD),
960 . ITAG(NUMNOD)
961 my_real,
962 . DIMENSION(:), ALLOCATABLE :: sbuf, rbuf
963 INTEGER MSGOFF,MSGOFF2
964 DATA msgoff/17004/
965 DATA msgoff2/17005/
966C-----------------------------------------------
967C S o u r c e L i n e s
968C-----------------------------------------------
969 loc_proc = ispmd + 1
970C-----
971 DO i=1,numnod
972 itag(i)=0
973 END DO
974C
975 siz = 0
976 DO p=1,nspmd
977 sizr(p)=0
978 sizs(p)=0
979 IF(p/=loc_proc)THEN
980C
981 DO j=iad_elem(1,p), iad_elem(1,p+1)-1
982 nod = fr_elem(j)
983 itag(nod)=j-iad_elem(1,p)+1
984 END DO
985C
986 msgtyp = msgoff
987 CALL mpi_irecv(
988 . sizr(p),1,mpi_integer,it_spmd(p),msgtyp,
989 . spmd_comm_world,req_r(p),ierror )
990C
991 IF(iad_elem(1,p+1)-iad_elem(1,p)/=0)THEN
992 DO j=iad_elem(1,p), iad_elem(1,p+1)-1
993 nod = fr_elem(j)
994 DO k=iadk(nod),iadk(nod+1)-1
995 m=jdik(k)
996 IF(itag(m)/=0.AND.itag(m)<itag(nod))THEN
997 sizs(p) = sizs(p) + 3
998 END IF
999 END DO
1000 END DO
1001 END IF
1002C
1003C reset
1004 DO j=iad_elem(1,p), iad_elem(1,p+1)-1
1005 nod = fr_elem(j)
1006 itag(nod)=0
1007 END DO
1008C
1009 msgtyp = msgoff
1010 CALL mpi_isend(
1011 . sizs(p),1,mpi_integer,it_spmd(p),msgtyp,
1012 . spmd_comm_world,req_s(p),ierror )
1013C
1014 siz = siz + sizs(p)
1015 END IF
1016 END DO
1017C
1018 ALLOCATE(sbuf(siz),stat=ierror)
1019 IF(ierror/=0) THEN
1020 CALL ancmsg(msgid=19,anmode=aninfo,
1021 . c1='FOR FSAI')
1022 CALL arret(2)
1023 END IF
1024C
1025 siz = 0
1026 DO p=1,nspmd
1027 IF(p/=loc_proc)THEN
1028 CALL mpi_wait(req_r(p),status,ierror)
1029 siz = siz +sizr(p)
1030 END IF
1031 END DO
1032C
1033 ALLOCATE(rbuf(siz),stat=ierror)
1034 IF(ierror/=0) THEN
1035 CALL ancmsg(msgid=19,anmode=aninfo,
1036 . c1='FOR FSAI')
1037 CALL arret(2)
1038 END IF
1039C
1040 l = 1
1041 DO p=1,nspmd
1042 IF(p/=loc_proc)THEN
1043 CALL mpi_wait(req_r(p),status,ierror)
1044 IF(sizr(p)/=0)THEN
1045 msgtyp = msgoff2
1046 CALL mpi_irecv(rbuf(l),sizr(p),real ,it_spmd(p),
1047 . msgtyp,spmd_comm_world,req_r(p),ierror)
1048 l = l +sizr(p)
1049 END IF
1050 END IF
1051 END DO
1052C
1053 l = 1
1054 ll = 1
1055 DO p=1,nspmd
1056 IF(sizs(p)/=0)THEN
1057C
1058 DO j=iad_elem(1,p), iad_elem(1,p+1)-1
1059 nod = fr_elem(j)
1060 itag(nod)=j-iad_elem(1,p)+1
1061 END DO
1062C
1063 DO j=iad_elem(1,p), iad_elem(1,p+1)-1
1064 nod = fr_elem(j)
1065 DO k=iadk(nod),iadk(nod+1)-1
1066 m=jdik(k)
1067 IF(itag(m)/=0.AND.itag(m)<itag(nod))THEN
1068 sbuf(ll ) = itag(nod)
1069 sbuf(ll+1) = itag(m)
1070 sbuf(ll+2) = lt_k(k)
1071 ll = ll + 3
1072 END IF
1073 END DO
1074 END DO
1075C
1076 msgtyp = msgoff2
1077 CALL mpi_isend(sbuf(l),sizs(p),real ,it_spmd(p),
1078 . msgtyp,spmd_comm_world,req_s2(p),ierror)
1079 l = l + sizs(p)
1080C
1081C reset
1082 DO j=iad_elem(1,p), iad_elem(1,p+1)-1
1083 nod = fr_elem(j)
1084 itag(nod)=0
1085 END DO
1086C
1087 END IF
1088 END DO
1089C
1090 l = 1
1091 DO p=1,nspmd
1092 IF(sizr(p)/=0)THEN
1093 CALL mpi_wait(req_r(p),status,ierror)
1094 DO j=1,sizr(p)/3
1095 n = nint(rbuf(l))
1096 n = fr_elem(iad_elem(1,p) + n - 1)
1097 n = invnd(n)
1098 m = nint(rbuf(l+1))
1099 m = fr_elem(iad_elem(1,p) + m - 1)
1100 m = invnd(m)
1101 jdim(kadm(n)) = m
1102 lt_m(kadm(n))=rbuf(l+2)
1103 kadm(n)=kadm(n)+1
1104 l = l + 3
1105 END DO
1106 END IF
1107 END DO
1108C
1109 DO p=1,nspmd
1110 IF(p/=loc_proc)THEN
1111 CALL mpi_wait(req_s(p),status,ierror)
1112 END IF
1113 IF(sizs(p)/=0)THEN
1114 CALL mpi_wait(req_s2(p),status,ierror)
1115 END IF
1116 END DO
1117C--------------------------------------------------------------------
1118#endif
1119 RETURN
message_mod
Definition message_mod.F:1249
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:889
arret
subroutine arret(nn)
Definition arret.F:87

◆ spmd_glob_lmax()

subroutine spmd_glob_lmax ( lmax,
integer imax )

Definition at line 618 of file spmd_sms.F.

619C-----------------------------------------------
620C I m p l i c i t T y p e s
621C-----------------------------------------------
622 USE spmd_comm_world_mod, ONLY : spmd_comm_world
623#include "implicit_f.inc"
624C-----------------------------------------------------------------
625C M e s s a g e P a s s i n g
626C-----------------------------------------------
627#include "spmd.inc"
628C-----------------------------------------------
629C C o m m o n B l o c k s
630C-----------------------------------------------
631#include "com01_c.inc"
632#include "task_c.inc"
633C-----------------------------------------------
634C D u m m y A r g u m e n t s
635C-----------------------------------------------
636 INTEGER IMAX
637 my_real lmax
638C-----------------------------------------------
639C L o c a l V a r i a b l e s
640C-----------------------------------------------
641#ifdef MPI
642 INTEGER MSGTYP,I,LOC_PROC,IERROR,
643 . SIZ,STATUS(MPI_STATUS_SIZE)
644 DOUBLE PRECISION SBUF(2)
645 INTEGER MSGOFF
646 DATA msgoff/17010/
647C-----------------------------------------------
648C S o u r c e L i n e s
649C-----------------------------------------------
650 loc_proc = ispmd + 1
651 siz = 2
652 IF(loc_proc==1)THEN
653 DO i=2,nspmd
654 msgtyp = msgoff
655 CALL mpi_recv(
656 s sbuf,siz,mpi_double_precision,it_spmd(i),msgtyp,
657 g spmd_comm_world,status,ierror)
658 IF(sbuf(1) > lmax)THEN
659 lmax=sbuf(1)
660 imax=nint(sbuf(2))
661 END IF
662 END DO
663 ELSE
664 sbuf(1)=lmax
665 sbuf(2)=imax
666 msgtyp = msgoff
667 CALL mpi_send(
668 s sbuf,siz,mpi_double_precision,it_spmd(1),msgtyp,
669 g spmd_comm_world,ierror)
670 END IF
671C
672 RETURN
673#endif
mpi_recv
subroutine mpi_recv(buf, cnt, datatype, source, tag, comm, status, ierr)
Definition mpi.f:461
mpi_send
subroutine mpi_send(buf, cnt, datatype, dest, tag, comm, ierr)
Definition mpi.f:480

◆ spmd_glob_lmin()

subroutine spmd_glob_lmin ( lmin,
integer imin )

Definition at line 554 of file spmd_sms.F.

555C-----------------------------------------------
556C I m p l i c i t T y p e s
557C-----------------------------------------------
558 USE spmd_comm_world_mod, ONLY : spmd_comm_world
559#include "implicit_f.inc"
560C-----------------------------------------------------------------
561C M e s s a g e P a s s i n g
562C-----------------------------------------------
563#include "spmd.inc"
564C-----------------------------------------------
565C C o m m o n B l o c k s
566C-----------------------------------------------
567#include "com01_c.inc"
568#include "task_c.inc"
569C-----------------------------------------------
570C D u m m y A r g u m e n t s
571C-----------------------------------------------
572 INTEGER IMIN
573 my_real lmin
574#ifdef MPI
575C-----------------------------------------------
576C L o c a l V a r i a b l e s
577C-----------------------------------------------
578 INTEGER MSGTYP,I,LOC_PROC,IERROR,
579 . SIZ,STATUS(MPI_STATUS_SIZE)
580 DOUBLE PRECISION SBUF(2)
581 INTEGER MSGOFF
582 DATA msgoff/17009/
583C-----------------------------------------------
584C S o u r c e L i n e s
585C-----------------------------------------------
586 loc_proc = ispmd + 1
587 siz = 2
588 IF(loc_proc==1)THEN
589 DO i=2,nspmd
590 msgtyp = msgoff
591 CALL mpi_recv(
592 s sbuf,siz,mpi_double_precision,it_spmd(i),msgtyp,
593 g spmd_comm_world,status,ierror)
594 IF(sbuf(1)<lmin)THEN
595 lmin=sbuf(1)
596 imin=nint(sbuf(2))
597 END IF
598 END DO
599 ELSE
600 sbuf(1)=lmin
601 sbuf(2)=imin
602 msgtyp = msgoff
603 CALL mpi_send(
604 s sbuf,siz,mpi_double_precision,it_spmd(1),msgtyp,
605 g spmd_comm_world,ierror)
606 END IF
607C
608#endif
609 RETURN

◆ spmd_list_sms()

subroutine spmd_list_sms ( integer, dimension(lskyi_sms,*) iskyi_sms,
integer, dimension(nspmd+1) fr_sms,
integer, dimension(nspmd+1) fr_rms,
integer, dimension(*) list_sms,
integer, dimension(*) list_rms,
integer, dimension(nnpby,*) npby,
integer, dimension(*) tagslv_rby_sms )

Definition at line 260 of file spmd_sms.F.

263C-----------------------------------------------
264C I m p l i c i t T y p e s
265C-----------------------------------------------
266 USE spmd_comm_world_mod, ONLY : spmd_comm_world
267#include "implicit_f.inc"
268C-----------------------------------------------
269C M e s s a g e P a s s i n g
270C-----------------------------------------------
271#include "spmd.inc"
272C-----------------------------------------------
273C C o m m o n B l o c k s
274C-----------------------------------------------
275#include "com01_c.inc"
276#include "param_c.inc"
277#include "sms_c.inc"
278#include "task_c.inc"
279C-----------------------------------------------
280C D u m m y A r g u m e n t s
281C-----------------------------------------------
282 INTEGER ISKYI_SMS(LSKYI_SMS,*), FR_SMS(NSPMD+1),
283 . FR_RMS(NSPMD+1), LIST_SMS(*), LIST_RMS(*),
284 . NPBY(NNPBY,*), TAGSLV_RBY_SMS(*)
285#ifdef MPI
286C-----------------------------------------------
287C L o c a l V a r i a b l e s
288C-----------------------------------------------
289 INTEGER MSGTYP,I,LOC_PROC,IERROR,
290 . SIZ,J,L,M,TAG,
291 . STATUS(MPI_STATUS_SIZE),
292 . REQ_R(NSPMD),REQ_S(NSPMD),
293 . SBUF(MAX(2*FR_SMS(NSPMD+1),FR_RMS(NSPMD+1))),
294 . RBUF(MAX(2*FR_RMS(NSPMD+1),FR_SMS(NSPMD+1)))
295 INTEGER MSGOFF,MSGOFF2
296 DATA msgoff/17006/
297 DATA msgoff2/17007/
298
299
300C-----------------------------------------------
301C S o u r c e L i n e s
302C-----------------------------------------------
303 loc_proc = ispmd + 1
304 l = 1
305 DO i=1,nspmd
306 siz = 2*(fr_rms(i+1)-fr_rms(i))
307 IF(siz/=0)THEN
308c print *,'irecv1',loc_proc,i,siz
309 msgtyp = msgoff
310 CALL mpi_irecv(
311 s rbuf(l),siz,mpi_integer,it_spmd(i),msgtyp,
312 g spmd_comm_world,req_r(i),ierror)
313 l = l + siz
314 ENDIF
315 END DO
316C
317 l = 1
318 m = 1
319 DO i=1,nspmd
320 IF(i/=loc_proc)THEN
321#include "vectorize.inc"
322 DO j=fr_sms(i),fr_sms(i+1)-1
323 sbuf(l ) = iskyi_sms(j,1)
324 l = l + 1
325 sbuf(l ) = tagslv_rby_sms(iskyi_sms(j,2))
326 l = l + 1
327 list_sms(m)= iskyi_sms(j,2)
328 m = m + 1
329 END DO
330 ELSE
331 l = l + 2*(fr_sms(i+1)-fr_sms(i))
332 END IF
333 ENDDO
334C
335C echange messages
336C
337 DO i=1,nspmd
338 IF(i/=loc_proc.AND.fr_sms(i+1)-fr_sms(i)>0)THEN
339 msgtyp = msgoff
340 siz = 2*(fr_sms(i+1)-fr_sms(i))
341c print *,'isend1',loc_proc,i,siz
342 l = 2*fr_sms(i)-1
343 CALL mpi_isend(
344 s sbuf(l),siz,mpi_integer,it_spmd(i),msgtyp,
345 g spmd_comm_world,req_s(i),ierror)
346 ENDIF
347 ENDDO
348C
349 DO i = 1, nspmd
350 IF(fr_rms(i+1)-fr_rms(i)>0)THEN
351 CALL mpi_wait(req_r(i),status,ierror)
352
353 l = 2*fr_rms(i)-1
354 DO j=fr_rms(i),fr_rms(i+1)-1
355 list_rms(j)= rbuf(l)
356 tag = rbuf(l+1)
357 IF(tag/=0.AND.tag==tagslv_rby_sms(list_rms(j)))THEN
358 list_rms(j)=0
359 END IF
360 l = l + 2
361 END DO
362
363 ENDIF
364 END DO
365C
366 DO i = 1, nspmd
367 IF(i/=loc_proc.AND.fr_sms(i+1)-fr_sms(i)>0)THEN
368 CALL mpi_wait(req_s(i),status,ierror)
369 ENDIF
370 END DO
371C
372C rby
373 l = 1
374 DO i=1,nspmd
375 siz = fr_sms(i+1)-fr_sms(i)
376 IF(i/=loc_proc.AND.siz>0)THEN
377c print *,'irecv2',loc_proc,i,siz
378 msgtyp = msgoff2
379 CALL mpi_irecv(
380 s rbuf(l),siz,mpi_integer,it_spmd(i),msgtyp,
381 g spmd_comm_world,req_r(i),ierror)
382 l = l + siz
383 ELSE
384 l = l + siz
385 ENDIF
386 END DO
387C
388 l = 1
389 DO i=1,nspmd
390 IF(fr_rms(i+1)-fr_rms(i)>0)THEN
391#include "vectorize.inc"
392 DO j=fr_rms(i),fr_rms(i+1)-1
393C LIST_RMS(J) ?= 0
394 sbuf(l ) = list_rms(j)
395 l = l + 1
396 END DO
397 END IF
398 ENDDO
399C
400 DO i=1,nspmd
401 IF(fr_rms(i+1)-fr_rms(i)>0)THEN
402 msgtyp = msgoff2
403 siz = fr_rms(i+1)-fr_rms(i)
404c print *,'isend2',loc_proc,i,siz
405 l = fr_rms(i)
406 CALL mpi_isend(
407 s sbuf(l),siz,mpi_integer,it_spmd(i),msgtyp,
408 g spmd_comm_world,req_s(i),ierror)
409 ENDIF
410 ENDDO
411C
412 m = 1
413 DO i = 1, nspmd
414 IF(i/=loc_proc.AND.fr_sms(i+1)-fr_sms(i)>0)THEN
415 CALL mpi_wait(req_r(i),status,ierror)
416
417 l = fr_sms(i)
418 DO j=fr_sms(i),fr_sms(i+1)-1
419 tag = rbuf(l)
420 IF(tag==0)THEN
421 list_sms(m)=0
422 END IF
423 l = l + 1
424 m = m + 1
425 END DO
426 ENDIF
427 END DO
428C
429 DO i = 1, nspmd
430 IF(fr_rms(i+1)-fr_rms(i)>0)THEN
431 CALL mpi_wait(req_s(i),status,ierror)
432 ENDIF
433 END DO
434C--------------------------------------------------------------------
435#endif
436 RETURN

◆ spmd_mij_sms()

subroutine spmd_mij_sms ( integer, dimension(lskyi_sms,*) iskyi_sms,
integer, dimension(nspmd+1) fr_sms,
integer, dimension(nspmd+1) fr_rms,
integer, dimension(*) list_rms,
mskyi_sms,
mij_sms )

Definition at line 449 of file spmd_sms.F.

452C-----------------------------------------------
453C I m p l i c i t T y p e s
454C-----------------------------------------------
455 USE spmd_comm_world_mod, ONLY : spmd_comm_world
456#include "implicit_f.inc"
457C-----------------------------------------------
458C M e s s a g e P a s s i n g
459C-----------------------------------------------
460#include "spmd.inc"
461C-----------------------------------------------
462C C o m m o n B l o c k s
463C-----------------------------------------------
464#include "com01_c.inc"
465#include "sms_c.inc"
466#include "task_c.inc"
467C-----------------------------------------------
468C D u m m y A r g u m e n t s
469C-----------------------------------------------
470 INTEGER ISKYI_SMS(LSKYI_SMS,*), FR_SMS(NSPMD+1),
471 . FR_RMS(NSPMD+1), LIST_RMS(*)
472 my_real
473 . mskyi_sms(*), mij_sms(*)
474#ifdef MPI
475C-----------------------------------------------
476C L o c a l V a r i a b l e s
477C-----------------------------------------------
478 INTEGER MSGTYP,I,LOC_PROC,IERROR,
479 . SIZ,J,L,
480 . STATUS(MPI_STATUS_SIZE),
481 . REQ_R(NSPMD),REQ_S(NSPMD)
482 my_real
483 . sbuf(fr_sms(nspmd+1))
484 INTEGER MSGOFF
485 DATA msgoff/17008/
486C-----------------------------------------------
487C S o u r c e L i n e s
488C-----------------------------------------------
489 loc_proc = ispmd + 1
490 l = 1
491 DO i=1,nspmd
492 siz = fr_rms(i+1)-fr_rms(i)
493 IF(siz/=0)THEN
494 msgtyp = msgoff
495c print *,'mij-irecv',loc_proc,i,siz
496 CALL mpi_irecv(
497 s mij_sms(l),siz,real,it_spmd(i),msgtyp,
498 g spmd_comm_world,req_r(i),ierror)
499 l = l + siz
500 ENDIF
501 END DO
502 l = 1
503 DO i=1,nspmd
504 IF(i/=loc_proc)THEN
505#include "vectorize.inc"
506 DO j=fr_sms(i),fr_sms(i+1)-1
507 sbuf(l ) = mskyi_sms(j)
508 l = l + 1
509 END DO
510 ELSE
511 l = l + fr_sms(i+1)-fr_sms(i)
512 END IF
513 ENDDO
514C
515C echange messages
516C
517 DO i=1,nspmd
518 IF(i/=loc_proc.AND.fr_sms(i+1)-fr_sms(i)>0)THEN
519 msgtyp = msgoff
520 siz = fr_sms(i+1)-fr_sms(i)
521c print *,'mij-isend',loc_proc,i,siz
522 l = fr_sms(i)
523 CALL mpi_isend(
524 s sbuf(l),siz,real,it_spmd(i),msgtyp,
525 g spmd_comm_world,req_s(i),ierror)
526 ENDIF
527 ENDDO
528C
529 DO i = 1, nspmd
530 IF(fr_rms(i+1)-fr_rms(i)>0)THEN
531 CALL mpi_wait(req_r(i),status,ierror)
532 ENDIF
533 END DO
534C
535 DO i = 1, nspmd
536 IF(i/=loc_proc.AND.fr_sms(i+1)-fr_sms(i)>0)THEN
537 CALL mpi_wait(req_s(i),status,ierror)
538 ENDIF
539 ENDDO
540C
541C--------------------------------------------------------------------
542C
543#endif
544 RETURN

◆ spmd_nlist_sms()

subroutine spmd_nlist_sms ( integer, dimension(nspmd+1) fr_sms,
integer, dimension(nspmd+1) fr_rms )

Definition at line 183 of file spmd_sms.F.

184C-----------------------------------------------
185C I m p l i c i t T y p e s
186C-----------------------------------------------
187 USE spmd_comm_world_mod, ONLY : spmd_comm_world
188#include "implicit_f.inc"
189C-----------------------------------------------
190C M e s s a g e P a s s i n g
191C-----------------------------------------------
192#include "spmd.inc"
193C-----------------------------------------------
194C C o m m o n B l o c k s
195C-----------------------------------------------
196#include "com01_c.inc"
197#include "task_c.inc"
198C-----------------------------------------------
199C D u m m y A r g u m e n t s
200C-----------------------------------------------
201 INTEGER FR_SMS(NSPMD+1), FR_RMS(NSPMD+1)
202#ifdef MPI
203C-----------------------------------------------
204C L o c a l V a r i a b l e s
205C-----------------------------------------------
206 INTEGER MSGTYP,I,LOC_PROC,IERROR,
207 . SIZ,J,L,
208 . STATUS(MPI_STATUS_SIZE),
209 . IAD_SEND(NSPMD+1),IAD_RECV(NSPMD+1),
210 . REQ_R(NSPMD),REQ_S(NSPMD)
211 INTEGER, DIMENSION(:), ALLOCATABLE:: BUFFER_SEND
212 INTEGER, DIMENSION(:), ALLOCATABLE :: BUFFER_RECV
213 INTEGER MSGOFF
214 DATA msgoff/17000/
215C-----------------------------------------------
216C S o u r c e L i n e s
217C-----------------------------------------------
218 loc_proc = ispmd + 1
219
220 ALLOCATE(buffer_recv(nspmd),buffer_send(nspmd))
221 DO i = 1,nspmd
222 IF(i == loc_proc) THEN
223 buffer_send(i) = 0
224 ELSE
225 buffer_send(i) = fr_sms(i+1)-fr_sms(i)
226 ENDIF
227 ENDDO
228 buffer_recv = 0
229 siz = 1
230
231 ! Buffer copy can be avoided using MPI_INPLACE but has not been tested with all MPI implementations
232 CALL mpi_alltoall(buffer_send,siz,mpi_integer,buffer_recv,siz,mpi_integer,spmd_comm_world,ierror)
233
234 fr_rms(1) = 1
235 DO i=1,nspmd
236 fr_rms(i+1) = buffer_recv(i)
237 ENDDO
238
239 fr_rms(1)=1
240 DO i = 1, nspmd
241 fr_rms(i+1)=fr_rms(i)+fr_rms(i+1)
242 END DO
243c
244 DEALLOCATE(buffer_send,buffer_recv)
245C
246#endif
247 RETURN
mpi_alltoall
subroutine mpi_alltoall(sendbuf, sendcnt, sendtype, recvbuf, recvcnt, recvtype, comm, ierr)
Definition mpi.f:161

◆ spmd_nndft_sms()

subroutine spmd_nndft_sms ( integer, dimension(nspmd+1) fr_sms,
integer, dimension(nspmd+1) fr_rms,
integer, dimension(*) list_sms,
integer, dimension(*) list_rms,
integer, dimension(2,*) iad_elem,
integer, dimension(*) fr_elem,
integer nndft0,
integer nndft1,
integer, dimension(*) isortnd )

Definition at line 683 of file spmd_sms.F.

686C-----------------------------------------------
687C I m p l i c i t T y p e s
688C-----------------------------------------------
689 USE spmd_comm_world_mod, ONLY : spmd_comm_world
690#include "implicit_f.inc"
691C-----------------------------------------------
692C M e s s a g e P a s s i n g
693C-----------------------------------------------
694#include "spmd.inc"
695C-----------------------------------------------
696C C o m m o n B l o c k s
697C-----------------------------------------------
698#include "com01_c.inc"
699#include "com04_c.inc"
700#include "task_c.inc"
701C-----------------------------------------------
702C D u m m y A r g u m e n t s
703C-----------------------------------------------
704 INTEGER FR_SMS(NSPMD+1), FR_RMS(NSPMD+1),
705 . LIST_SMS(*), LIST_RMS(*), IAD_ELEM(2,*), FR_ELEM(*),
706 . NNDFT0,NNDFT1,ISORTND(*)
707#ifdef MPI
708C-----------------------------------------------
709C L o c a l V a r i a b l e s
710C-----------------------------------------------
711 INTEGER MSGTYP,I,LOC_PROC,IERROR,
712 . SIZ,J,L,M,NOD,
713 . ITAG(NUMNOD),NNDFT(NSPMD),MNDFT(NSPMD),KSORT,
714 . STATUS(MPI_STATUS_SIZE),
715 . REQ_R(NSPMD),REQ_S(NSPMD),
716 . SBUF(MAX(2*FR_SMS(NSPMD+1),FR_RMS(NSPMD+1))),
717 . RBUF(MAX(2*FR_RMS(NSPMD+1),FR_SMS(NSPMD+1)))
718C-----------------------------------------------
719C S o u r c e L i n e s
720C-----------------------------------------------
721 loc_proc = ispmd + 1
722C
723 DO i=1,numnod
724 itag(i)=0
725 END DO
726C
727 nndft0=0
728 DO j=iad_elem(1,1),iad_elem(1,ispmd+1)-1
729 nod=fr_elem(j)
730 IF(itag(nod)==0)THEN
731 nndft0=nndft0+1
732 isortnd(nndft0)=nod
733 itag(nod)=1
734 END IF
735 END DO
736
737 DO j=iad_elem(1,ispmd+1),iad_elem(1,nspmd+1)-1
738 nod=fr_elem(j)
739 itag(nod)=1
740 END DO
741
742 ksort=nndft0
743 DO nod=1,numnod
744 IF(itag(nod)==0)THEN
745 ksort=ksort+1
746 isortnd(ksort)=nod
747 END IF
748 END DO
749 DO j=iad_elem(1,1),iad_elem(1,nspmd+1)-1
750 nod=fr_elem(j)
751 itag(nod)=0
752 END DO
753
754 DO j=iad_elem(1,1),iad_elem(1,ispmd+1)-1
755 nod=fr_elem(j)
756 itag(nod)=1
757 END DO
758 nndft1=0
759 DO j=iad_elem(1,ispmd+1),iad_elem(1,nspmd+1)-1
760 nod=fr_elem(j)
761 IF(itag(nod)==0)THEN
762 nndft1=nndft1+1
763 ksort =ksort+1
764 isortnd(ksort)=nod
765 itag(nod)=1
766 END IF
767 END DO
768#endif
769C--------------------------------------------------------------------
770 RETURN

◆ spmd_nnz_sms()

subroutine spmd_nnz_sms ( integer, dimension(nspmd+1) fr_sms,
integer, dimension(nspmd+1) fr_rms,
integer, dimension(*) list_sms,
integer, dimension(*) list_rms,
integer, dimension(2,*) iad_elem,
integer, dimension(*) fr_elem,
integer nnzm,
integer, dimension(*) iadk,
integer, dimension(*) kadm )

Definition at line 781 of file spmd_sms.F.

784C-----------------------------------------------
785C I m p l i c i t T y p e s
786C-----------------------------------------------
787 USE spmd_comm_world_mod, ONLY : spmd_comm_world
788#include "implicit_f.inc"
789C-----------------------------------------------
790C M e s s a g e P a s s i n g
791C-----------------------------------------------
792#include "spmd.inc"
793C-----------------------------------------------
794C C o m m o n B l o c k s
795C-----------------------------------------------
796#include "com01_c.inc"
797#include "task_c.inc"
798C-----------------------------------------------
799C D u m m y A r g u m e n t s
800C-----------------------------------------------
801 INTEGER FR_SMS(NSPMD+1), FR_RMS(NSPMD+1),
802 . LIST_SMS(*), LIST_RMS(*), IAD_ELEM(2,*), FR_ELEM(*),
803 . NNZM, IADK(*), KADM(*)
804#ifdef MPI
805C-----------------------------------------------
806C L o c a l V a r i a b l e s
807C-----------------------------------------------
808 INTEGER MSGTYP,I,LOC_PROC,IERROR,
809 . SIZ,J,L,M,NOD,P,
810 . NNZP(NSPMD),MNZP(NSPMD),
811 . STATUS(MPI_STATUS_SIZE),
812 . REQ_R(NSPMD),REQ_S(NSPMD),
813 . SBUF(IAD_ELEM(1,NSPMD+1)-IAD_ELEM(1,1)),
814 . RBUF(IAD_ELEM(1,NSPMD+1)-IAD_ELEM(1,1))
815 INTEGER MSGOFF,MSGOFF2
816 DATA msgoff/17002/
817 DATA msgoff2/17003/
818
819
820C-----------------------------------------------
821C S o u r c e L i n e s
822C-----------------------------------------------
823 loc_proc = ispmd + 1
824C
825 l = 1
826 m = 1
827 siz=1
828 DO p=1,nspmd
829 nnzp(p) = 0
830 mnzp(p) = 0
831 IF(p/=loc_proc)THEN
832C
833 DO j=iad_elem(1,p), iad_elem(1,p+1)-1
834 nod = fr_elem(j)
835 nnzp(p) = nnzp(p) + iadk(nod+1)-iadk(nod)
836 END DO
837C
838 !THIS IS A BUG => DEADLOCK
839 msgtyp = msgoff
840 CALL mpi_send(
841 s nnzp(p),siz,mpi_integer,it_spmd(p),msgtyp,
842 g spmd_comm_world,ierror)
843 msgtyp = msgoff
844 CALL mpi_recv(
845 s mnzp(p),siz,mpi_integer,it_spmd(p),msgtyp,
846 g spmd_comm_world,status,ierror)
847 END IF
848 END DO
849C
850C echange messages
851C
852c SIZ=1
853c CALL MPI_ALLTOALL(NNZP,SIZ,MPI_INTEGER,MNZP,SIZ,MPI_INTEGER,
854c . SPMD_COMM_WORLD,IERROR)
855C
856C sur dimensionne
857 DO p = 1, nspmd
858 nnzm=nnzm+mnzp(p)
859 END DO
860C-----
861 l = 1
862 DO p=1,nspmd
863C
864 siz = iad_elem(1,p+1)-iad_elem(1,p)
865 IF(siz/=0)THEN
866 msgtyp = msgoff2
867 CALL mpi_irecv(
868 . rbuf(l),siz,mpi_integer,it_spmd(p),msgtyp,
869 . spmd_comm_world,req_r(p),ierror )
870C
871 DO j=iad_elem(1,p), iad_elem(1,p+1)-1
872 nod = fr_elem(j)
873 sbuf(j)=iadk(nod+1)-iadk(nod)
874 END DO
875C
876 msgtyp= msgoff2
877 CALL mpi_isend(
878 . sbuf(l),siz,mpi_integer,it_spmd(p),msgtyp,
879 . spmd_comm_world,req_s(p),ierror )
880 l = l + siz
881 END IF
882C
883 END DO
884C
885 l = 1
886 DO p=1,nspmd
887 siz = iad_elem(1,p+1)-iad_elem(1,p)
888 IF(siz/=0)THEN
889 CALL mpi_wait(req_r(p),status,ierror)
890 DO j=iad_elem(1,p),iad_elem(1,p+1)-1
891 nod = fr_elem(j)
892 kadm(nod)=kadm(nod)+rbuf(l)
893 l = l + 1
894 END DO
895 END IF
896 END DO
897C
898 DO p=1,nspmd
899 IF(iad_elem(1,p+1)-iad_elem(1,p)/=0)THEN
900 CALL mpi_wait(req_s(p),status,ierror)
901 END IF
902 END DO
903C--------------------------------------------------------------------
904#endif
905 RETURN

◆ spmd_sort_sms()

subroutine spmd_sort_sms ( integer, dimension(lskyi_sms,*) iskyi_sms,
mskyi_sms,
integer, dimension(nspmd+1) fr_sms )

Definition at line 32 of file spmd_sms.F.

33C-----------------------------------------------
34C M o d u l e s
35C-----------------------------------------------
36 USE my_alloc_mod
37C-----------------------------------------------
38C I m p l i c i t T y p e s
39C-----------------------------------------------
40 USE spmd_comm_world_mod, ONLY : spmd_comm_world
41#include "implicit_f.inc"
42C-----------------------------------------------
43C C o m m o n B l o c k s
44C-----------------------------------------------
45#include "com01_c.inc"
46#include "parit_c.inc"
47#include "sms_c.inc"
48C-----------------------------------------------
49C D u m m y A r g u m e n t s
50C-----------------------------------------------
51 INTEGER ISKYI_SMS(LSKYI_SMS,*), FR_SMS(NSPMD+1)
52 my_real mskyi_sms(*)
53C-----------------------------------------------
54C L o c a l V a r i a b l e s
55C-----------------------------------------------
56 INTEGER N,NN, P, Q, PP, kk
57 INTEGER,DIMENSION(:,:),ALLOCATABLE :: I2SORT
58 INTEGER LP(NSPMD+1), NP(NSPMD+1)
59 my_real, DIMENSION(:), ALLOCATABLE :: m2sort
60C-----------------------------------------------
61C S o u r c e L i n e s
62C-----------------------------------------------
63 CALL my_alloc( i2sort,nisky_sms,3)
64 CALL my_alloc(m2sort,nisky_sms)
65C
66 DO n = 1, nisky_sms
67 i2sort(n,1)= iskyi_sms(n,1)
68 i2sort(n,2)= iskyi_sms(n,2)
69 i2sort(n,3)= iskyi_sms(n,3)
70 m2sort(n) = mskyi_sms(n)
71 ENDDO
72C
73 DO p=1,nspmd
74 lp(p)=0
75 END DO
76C
77 DO n = 1, nisky_sms
78 p = i2sort(n,3)
79 lp(p)=lp(p)+1
80 END DO
81C
82 np(1)=1
83 DO p=1,nspmd
84 np(p+1)=np(p)+lp(p)
85 END DO
86C
87 DO p=1,nspmd+1
88 fr_sms(p)=np(p)
89 END DO
90C
91 DO n = 1, nisky_sms
92 p = i2sort(n,3)
93 nn=np(p)
94 iskyi_sms(nn,1)=i2sort(n,1)
95 iskyi_sms(nn,2)=i2sort(n,2)
96 iskyi_sms(nn,3)=i2sort(n,3)
97 mskyi_sms(nn) =m2sort(n)
98 np(p)=np(p)+1
99 ENDDO
100C
101 DEALLOCATE(i2sort)
102 DEALLOCATE(m2sort)
103
104 RETURN