mirror of
https://github.com/saitohirga/WSJT-X.git
synced 2025-04-05 10:58:38 -04:00
More conversions from .f to .f90.
git-svn-id: svn+ssh://svn.code.sf.net/p/wsjt/wsjt/branches/map65@7475 ab8295b8-cf94-4d9e-aec4-7959e3be5d79
This commit is contained in:
Joe Taylor
parent
e5c1c14543
commit
c3102ea485
@ -101,30 +101,31 @@ set (FSRCS
|
||||
map65a.f90
|
||||
moon2.f90
|
||||
moondop.f90
|
||||
nchar.f90
|
||||
noisegen.f90
|
||||
packcall.f90
|
||||
packdxcc.f90
|
||||
packgrid.f90
|
||||
packmsg.f90
|
||||
packtext.f90
|
||||
pctile.f90
|
||||
pfxdump.f90
|
||||
recvpkt.f90
|
||||
rfile3a.f90
|
||||
s3avg.f90
|
||||
sec_midn.f90
|
||||
set.f90
|
||||
setup65.f90
|
||||
sleep_msec.f90
|
||||
symspec.f90
|
||||
sort.f90
|
||||
|
||||
symspec.f90
|
||||
timer.f90
|
||||
timf2.f90
|
||||
tm2.f90
|
||||
zplot.f90
|
||||
|
||||
f77_wisdom.f
|
||||
nchar.f
|
||||
packcall.f
|
||||
packdxcc.f
|
||||
packgrid.f
|
||||
packmsg.f
|
||||
packtext.f
|
||||
pctile.f
|
||||
set.f
|
||||
setup65.f
|
||||
sort.f
|
||||
ssort.f
|
||||
sun.f
|
||||
toxyz.f
|
||||
|
||||
@ -1,23 +0,0 @@
|
||||
function nchar(c)
|
||||
|
||||
C Convert ascii number, letter, or space to 0-36 for callsign packing.
|
||||
|
||||
character c*1
|
||||
|
||||
n=0 !Silence compiler warning
|
||||
if(c.ge.'0' .and. c.le.'9') then
|
||||
n=ichar(c)-ichar('0')
|
||||
else if(c.ge.'A' .and. c.le.'Z') then
|
||||
n=ichar(c)-ichar('A') + 10
|
||||
else if(c.ge.'a' .and. c.le.'z') then
|
||||
n=ichar(c)-ichar('a') + 10
|
||||
else if(c.ge.' ') then
|
||||
n=36
|
||||
else
|
||||
Print*,'Invalid character in callsign ',c,' ',ichar(c)
|
||||
call exit(1)
|
||||
endif
|
||||
nchar=n
|
||||
|
||||
return
|
||||
end
|
||||
23
libm65/nchar.f90
Normal file
23
libm65/nchar.f90
Normal file
@ -0,0 +1,23 @@
|
||||
function nchar(c)
|
||||
|
||||
! Convert ascii number, letter, or space to 0-36 for callsign packing.
|
||||
|
||||
character c*1
|
||||
|
||||
n=0 !Silence compiler warning
|
||||
if(c.ge.'0' .and. c.le.'9') then
|
||||
n=ichar(c)-ichar('0')
|
||||
else if(c.ge.'A' .and. c.le.'Z') then
|
||||
n=ichar(c)-ichar('A') + 10
|
||||
else if(c.ge.'a' .and. c.le.'z') then
|
||||
n=ichar(c)-ichar('a') + 10
|
||||
else if(c.ge.' ') then
|
||||
n=36
|
||||
else
|
||||
Print*,'Invalid character in callsign ',c,' ',ichar(c)
|
||||
call exit(1)
|
||||
endif
|
||||
nchar=n
|
||||
|
||||
return
|
||||
end function nchar
|
||||
@ -1,79 +0,0 @@
|
||||
subroutine packcall(callsign,ncall,text)
|
||||
|
||||
C Pack a valid callsign into a 28-bit integer.
|
||||
|
||||
parameter (NBASE=37*36*10*27*27*27)
|
||||
character callsign*6,c*1,tmp*6
|
||||
logical text
|
||||
|
||||
text=.false.
|
||||
|
||||
C Work-around for Swaziland prefix:
|
||||
if(callsign(1:4).eq.'3DA0') callsign='3D0'//callsign(5:6)
|
||||
|
||||
if(callsign(1:3).eq.'CQ ') then
|
||||
ncall=NBASE + 1
|
||||
if(callsign(4:4).ge.'0' .and. callsign(4:4).le.'9' .and.
|
||||
+ callsign(5:5).ge.'0' .and. callsign(5:5).le.'9' .and.
|
||||
+ callsign(6:6).ge.'0' .and. callsign(6:6).le.'9') then
|
||||
read(callsign(4:6),*) nfreq
|
||||
ncall=NBASE + 3 + nfreq
|
||||
endif
|
||||
return
|
||||
else if(callsign(1:4).eq.'QRZ ') then
|
||||
ncall=NBASE + 2
|
||||
return
|
||||
else if(callsign(1:3).eq.'DE ') then
|
||||
ncall=267796945
|
||||
return
|
||||
endif
|
||||
|
||||
tmp=' '
|
||||
if(callsign(3:3).ge.'0' .and. callsign(3:3).le.'9') then
|
||||
tmp=callsign
|
||||
else if(callsign(2:2).ge.'0' .and. callsign(2:2).le.'9') then
|
||||
if(callsign(6:6).ne.' ') then
|
||||
text=.true.
|
||||
return
|
||||
endif
|
||||
tmp=' '//callsign(:5)
|
||||
else
|
||||
text=.true.
|
||||
return
|
||||
endif
|
||||
|
||||
do i=1,6
|
||||
c=tmp(i:i)
|
||||
if(c.ge.'a' .and. c.le.'z')
|
||||
+ tmp(i:i)=char(ichar(c)-ichar('a')+ichar('A'))
|
||||
enddo
|
||||
|
||||
n1=0
|
||||
if((tmp(1:1).ge.'A'.and.tmp(1:1).le.'Z').or.tmp(1:1).eq.' ') n1=1
|
||||
if(tmp(1:1).ge.'0' .and. tmp(1:1).le.'9') n1=1
|
||||
n2=0
|
||||
if(tmp(2:2).ge.'A' .and. tmp(2:2).le.'Z') n2=1
|
||||
if(tmp(2:2).ge.'0' .and. tmp(2:2).le.'9') n2=1
|
||||
n3=0
|
||||
if(tmp(3:3).ge.'0' .and. tmp(3:3).le.'9') n3=1
|
||||
n4=0
|
||||
if((tmp(4:4).ge.'A'.and.tmp(4:4).le.'Z').or.tmp(4:4).eq.' ') n4=1
|
||||
n5=0
|
||||
if((tmp(5:5).ge.'A'.and.tmp(5:5).le.'Z').or.tmp(5:5).eq.' ') n5=1
|
||||
n6=0
|
||||
if((tmp(6:6).ge.'A'.and.tmp(6:6).le.'Z').or.tmp(6:6).eq.' ') n6=1
|
||||
|
||||
if(n1+n2+n3+n4+n5+n6 .ne. 6) then
|
||||
text=.true.
|
||||
return
|
||||
endif
|
||||
|
||||
ncall=nchar(tmp(1:1))
|
||||
ncall=36*ncall+nchar(tmp(2:2))
|
||||
ncall=10*ncall+nchar(tmp(3:3))
|
||||
ncall=27*ncall+nchar(tmp(4:4))-10
|
||||
ncall=27*ncall+nchar(tmp(5:5))-10
|
||||
ncall=27*ncall+nchar(tmp(6:6))-10
|
||||
|
||||
return
|
||||
end
|
||||
78
libm65/packcall.f90
Normal file
78
libm65/packcall.f90
Normal file
@ -0,0 +1,78 @@
|
||||
subroutine packcall(callsign,ncall,text)
|
||||
|
||||
! Pack a valid callsign into a 28-bit integer.
|
||||
|
||||
parameter (NBASE=37*36*10*27*27*27)
|
||||
character callsign*6,c*1,tmp*6
|
||||
logical text
|
||||
|
||||
text=.false.
|
||||
|
||||
! Work-around for Swaziland prefix:
|
||||
if(callsign(1:4).eq.'3DA0') callsign='3D0'//callsign(5:6)
|
||||
|
||||
if(callsign(1:3).eq.'CQ ') then
|
||||
ncall=NBASE + 1
|
||||
if(callsign(4:4).ge.'0' .and. callsign(4:4).le.'9' .and. &
|
||||
callsign(5:5).ge.'0' .and. callsign(5:5).le.'9' .and. &
|
||||
callsign(6:6).ge.'0' .and. callsign(6:6).le.'9') then
|
||||
read(callsign(4:6),*) nfreq
|
||||
ncall=NBASE + 3 + nfreq
|
||||
endif
|
||||
return
|
||||
else if(callsign(1:4).eq.'QRZ ') then
|
||||
ncall=NBASE + 2
|
||||
return
|
||||
else if(callsign(1:3).eq.'DE ') then
|
||||
ncall=267796945
|
||||
return
|
||||
endif
|
||||
|
||||
tmp=' '
|
||||
if(callsign(3:3).ge.'0' .and. callsign(3:3).le.'9') then
|
||||
tmp=callsign
|
||||
else if(callsign(2:2).ge.'0' .and. callsign(2:2).le.'9') then
|
||||
if(callsign(6:6).ne.' ') then
|
||||
text=.true.
|
||||
return
|
||||
endif
|
||||
tmp=' '//callsign(:5)
|
||||
else
|
||||
text=.true.
|
||||
return
|
||||
endif
|
||||
|
||||
do i=1,6
|
||||
c=tmp(i:i)
|
||||
if(c.ge.'a' .and. c.le.'z') tmp(i:i)=char(ichar(c)-ichar('a')+ichar('A'))
|
||||
enddo
|
||||
|
||||
n1=0
|
||||
if((tmp(1:1).ge.'A'.and.tmp(1:1).le.'Z').or.tmp(1:1).eq.' ') n1=1
|
||||
if(tmp(1:1).ge.'0' .and. tmp(1:1).le.'9') n1=1
|
||||
n2=0
|
||||
if(tmp(2:2).ge.'A' .and. tmp(2:2).le.'Z') n2=1
|
||||
if(tmp(2:2).ge.'0' .and. tmp(2:2).le.'9') n2=1
|
||||
n3=0
|
||||
if(tmp(3:3).ge.'0' .and. tmp(3:3).le.'9') n3=1
|
||||
n4=0
|
||||
if((tmp(4:4).ge.'A'.and.tmp(4:4).le.'Z').or.tmp(4:4).eq.' ') n4=1
|
||||
n5=0
|
||||
if((tmp(5:5).ge.'A'.and.tmp(5:5).le.'Z').or.tmp(5:5).eq.' ') n5=1
|
||||
n6=0
|
||||
if((tmp(6:6).ge.'A'.and.tmp(6:6).le.'Z').or.tmp(6:6).eq.' ') n6=1
|
||||
|
||||
if(n1+n2+n3+n4+n5+n6 .ne. 6) then
|
||||
text=.true.
|
||||
return
|
||||
endif
|
||||
|
||||
ncall=nchar(tmp(1:1))
|
||||
ncall=36*ncall+nchar(tmp(2:2))
|
||||
ncall=10*ncall+nchar(tmp(3:3))
|
||||
ncall=27*ncall+nchar(tmp(4:4))-10
|
||||
ncall=27*ncall+nchar(tmp(5:5))-10
|
||||
ncall=27*ncall+nchar(tmp(6:6))-10
|
||||
|
||||
return
|
||||
end subroutine packcall
|
||||
@ -1,64 +0,0 @@
|
||||
subroutine packdxcc(c,ng,ldxcc)
|
||||
|
||||
character*3 c
|
||||
logical ldxcc
|
||||
|
||||
parameter (NZ=303)
|
||||
character*5 pfx(NZ)
|
||||
data pfx/
|
||||
+ '1A ','1S ','3A ','3B6 ','3B8 ','3B9 ','3C ','3C0 ',
|
||||
+ '3D2 ', '3DA ','3V ','3W ','3X ','3Y ',
|
||||
+ '4J ','4L ','4S ','4U1 ', '4W ',
|
||||
+ '4X ','5A ','5B ','5H ','5N ','5R ','5T ','5U ',
|
||||
+ '5V ','5W ','5X ','5Z ','6W ','6Y ','7O ','7P ',
|
||||
+ '7Q ','7X ','8P ','8Q ','8R ','9A ','9G ','9H ',
|
||||
+ '9J ','9K ','9L ','9M2 ','9M6 ','9N ','9Q ','9U ',
|
||||
+ '9V ','9X ','9Y ','A2 ','A3 ','A4 ','A5 ','A6 ',
|
||||
+ 'A7 ','A9 ','AP ','BS7 ','BV ','BV9 ','BY ','C2 ',
|
||||
+ 'C3 ','C5 ','C6 ','C9 ','CE ','CE0 ',
|
||||
+ 'CE9 ','CM ','CN ','CP ','CT ','CT3 ','CU ','CX ',
|
||||
+ 'CY0 ','CY9 ','D2 ','D4 ','D6 ','DL ','DU ','E3 ',
|
||||
+ 'E4 ','EA ','EA6 ','EA8 ','EA9 ','EI ','EK ','EL ',
|
||||
+ 'EP ','ER ','ES ','ET ','EU ','EX ','EY ','EZ ',
|
||||
+ 'F ','FG ','FH ','FJ ','FK ', 'FM ','FO ',
|
||||
+ 'FP ','FR ',
|
||||
+ 'FT5 ', 'FW ','FY ','M ','MD ','MI ',
|
||||
+ 'MJ ','MM ', 'MU ','MW ','H4 ','H40 ','HA ',
|
||||
+ 'HB ','HB0 ','HC ','HC8 ','HH ','HI ','HK ','HK0 ',
|
||||
+ 'HL ','HM ','HP ','HR ','HS ','HV ','HZ ',
|
||||
+ 'I ','IG9 ','IS ','IT9 ','J2 ','J3 ','J5 ','J6 ',
|
||||
+ 'J7 ','J8 ','JA ','JD ', 'JT ','JW ',
|
||||
+ 'JX ','JY ','K ','KG4 ','KH0 ','KH1 ','KH2 ','KH3 ',
|
||||
+ 'KH4 ','KH5 ', 'KH6 ','KH7 ','KH8 ','KH9 ','KL ',
|
||||
+ 'KP1 ','KP2 ','KP4 ','KP5 ','LA ','LU ','LX ','LY ',
|
||||
+ 'LZ ','OA ','OD ','OE ','OH ','OH0 ','OJ0 ','OK ',
|
||||
+ 'OM ','ON ','OX ','OY ','OZ ','P2 ','P4 ','PA ',
|
||||
+ 'PJ2 ','PJ7 ','PY ','PY0 ', 'PZ ','R1F ',
|
||||
+ 'R1M ','S0 ','S2 ','S5 ','S7 ','S9 ','SM ','SP ',
|
||||
+ 'ST ','SU ','SV ', 'SV5 ','SV9 ','T2 ','T30 ',
|
||||
+ 'T31 ','T32 ','T33 ','T5 ','T7 ','T8 ','T9 ','TA ',
|
||||
+ 'TA1 ','TF ','TG ','TI ','TI9 ','TJ ','TK ','TL ',
|
||||
+ 'TN ','TR ','TT ','TU ','TY ','TZ ','UA ','UA2 ',
|
||||
+ 'UA9 ','UK ','UN ','UR ','V2 ','V3 ','V4 ','V5 ',
|
||||
+ 'V6 ','V7 ','V8 ','VE ','VK ','VK0 ', 'VK9 ',
|
||||
+ 'VP2 ',
|
||||
+ 'VP5 ','VP6 ', 'VP8 ',
|
||||
+ 'VP9 ','VQ9 ','VR ','VU ','VU4 ','VU7 ','XE ','XF4 ',
|
||||
+ 'XT ','XU ','XW ','XX9 ','XZ ','YA ','YB ','YI ',
|
||||
+ 'YJ ','YK ','YL ','YN ','YO ','YS ','YU ','YV ',
|
||||
+ 'YV0 ','Z2 ','Z3 ','ZA ','ZB ','ZC4 ','ZD7 ','ZD8 ',
|
||||
+ 'ZD9 ','ZF ','ZK1 ', 'ZK2 ','ZK3 ','ZL ','ZL7 ',
|
||||
+ 'ZL8 ','ZL9 ','ZP ','ZS ','ZS8 '/
|
||||
|
||||
ldxcc=.false.
|
||||
ng=0
|
||||
do i=1,NZ
|
||||
if(pfx(i)(1:3).eq.c) go to 10
|
||||
enddo
|
||||
go to 20
|
||||
|
||||
10 ng=180*180+61+i
|
||||
ldxcc=.true.
|
||||
|
||||
20 return
|
||||
end
|
||||
64
libm65/packdxcc.f90
Normal file
64
libm65/packdxcc.f90
Normal file
@ -0,0 +1,64 @@
|
||||
subroutine packdxcc(c,ng,ldxcc)
|
||||
|
||||
character*3 c
|
||||
logical ldxcc
|
||||
|
||||
parameter (NZ=303)
|
||||
character*5 pfx(NZ)
|
||||
data pfx/ &
|
||||
'1A ','1S ','3A ','3B6 ','3B8 ','3B9 ','3C ','3C0 ', &
|
||||
'3D2 ', '3DA ','3V ','3W ','3X ','3Y ', &
|
||||
'4J ','4L ','4S ','4U1 ', '4W ', &
|
||||
'4X ','5A ','5B ','5H ','5N ','5R ','5T ','5U ', &
|
||||
'5V ','5W ','5X ','5Z ','6W ','6Y ','7O ','7P ', &
|
||||
'7Q ','7X ','8P ','8Q ','8R ','9A ','9G ','9H ', &
|
||||
'9J ','9K ','9L ','9M2 ','9M6 ','9N ','9Q ','9U ', &
|
||||
'9V ','9X ','9Y ','A2 ','A3 ','A4 ','A5 ','A6 ', &
|
||||
'A7 ','A9 ','AP ','BS7 ','BV ','BV9 ','BY ','C2 ', &
|
||||
'C3 ','C5 ','C6 ','C9 ','CE ','CE0 ', &
|
||||
'CE9 ','CM ','CN ','CP ','CT ','CT3 ','CU ','CX ', &
|
||||
'CY0 ','CY9 ','D2 ','D4 ','D6 ','DL ','DU ','E3 ', &
|
||||
'E4 ','EA ','EA6 ','EA8 ','EA9 ','EI ','EK ','EL ', &
|
||||
'EP ','ER ','ES ','ET ','EU ','EX ','EY ','EZ ', &
|
||||
'F ','FG ','FH ','FJ ','FK ', 'FM ','FO ', &
|
||||
'FP ','FR ', &
|
||||
'FT5 ', 'FW ','FY ','M ','MD ','MI ', &
|
||||
'MJ ','MM ', 'MU ','MW ','H4 ','H40 ','HA ', &
|
||||
'HB ','HB0 ','HC ','HC8 ','HH ','HI ','HK ','HK0 ', &
|
||||
'HL ','HM ','HP ','HR ','HS ','HV ','HZ ', &
|
||||
'I ','IG9 ','IS ','IT9 ','J2 ','J3 ','J5 ','J6 ', &
|
||||
'J7 ','J8 ','JA ','JD ', 'JT ','JW ', &
|
||||
'JX ','JY ','K ','KG4 ','KH0 ','KH1 ','KH2 ','KH3 ', &
|
||||
'KH4 ','KH5 ', 'KH6 ','KH7 ','KH8 ','KH9 ','KL ', &
|
||||
'KP1 ','KP2 ','KP4 ','KP5 ','LA ','LU ','LX ','LY ', &
|
||||
'LZ ','OA ','OD ','OE ','OH ','OH0 ','OJ0 ','OK ', &
|
||||
'OM ','ON ','OX ','OY ','OZ ','P2 ','P4 ','PA ', &
|
||||
'PJ2 ','PJ7 ','PY ','PY0 ', 'PZ ','R1F ', &
|
||||
'R1M ','S0 ','S2 ','S5 ','S7 ','S9 ','SM ','SP ', &
|
||||
'ST ','SU ','SV ', 'SV5 ','SV9 ','T2 ','T30 ', &
|
||||
'T31 ','T32 ','T33 ','T5 ','T7 ','T8 ','T9 ','TA ', &
|
||||
'TA1 ','TF ','TG ','TI ','TI9 ','TJ ','TK ','TL ', &
|
||||
'TN ','TR ','TT ','TU ','TY ','TZ ','UA ','UA2 ', &
|
||||
'UA9 ','UK ','UN ','UR ','V2 ','V3 ','V4 ','V5 ', &
|
||||
'V6 ','V7 ','V8 ','VE ','VK ','VK0 ', 'VK9 ', &
|
||||
'VP2 ', &
|
||||
'VP5 ','VP6 ', 'VP8 ', &
|
||||
'VP9 ','VQ9 ','VR ','VU ','VU4 ','VU7 ','XE ','XF4 ', &
|
||||
'XT ','XU ','XW ','XX9 ','XZ ','YA ','YB ','YI ', &
|
||||
'YJ ','YK ','YL ','YN ','YO ','YS ','YU ','YV ', &
|
||||
'YV0 ','Z2 ','Z3 ','ZA ','ZB ','ZC4 ','ZD7 ','ZD8 ', &
|
||||
'ZD9 ','ZF ','ZK1 ', 'ZK2 ','ZK3 ','ZL ','ZL7 ', &
|
||||
'ZL8 ','ZL9 ','ZP ','ZS ','ZS8 '/
|
||||
|
||||
ldxcc=.false.
|
||||
ng=0
|
||||
do i=1,NZ
|
||||
if(pfx(i)(1:3).eq.c) go to 10
|
||||
enddo
|
||||
go to 20
|
||||
|
||||
10 ng=180*180+61+i
|
||||
ldxcc=.true.
|
||||
|
||||
20 return
|
||||
end subroutine packdxcc
|
||||
@ -1,47 +0,0 @@
|
||||
subroutine packgrid(grid,ng,text)
|
||||
|
||||
parameter (NGBASE=180*180)
|
||||
character*4 grid
|
||||
logical text
|
||||
|
||||
text=.false.
|
||||
if(grid.eq.' ') go to 90 !Blank grid is OK
|
||||
|
||||
C Test for numerical signal report, etc.
|
||||
if(grid(1:1).eq.'-') then
|
||||
read(grid(2:3),*,err=1,end=1) n
|
||||
1 ng=NGBASE+1+n
|
||||
go to 100
|
||||
else if(grid(1:2).eq.'R-') then
|
||||
read(grid(3:4),*,err=2,end=2) n
|
||||
2 if(n.eq.0) go to 90
|
||||
ng=NGBASE+31+n
|
||||
go to 100
|
||||
else if(grid(1:2).eq.'RO') then
|
||||
ng=NGBASE+62
|
||||
go to 100
|
||||
else if(grid(1:3).eq.'RRR') then
|
||||
ng=NGBASE+63
|
||||
go to 100
|
||||
else if(grid(1:2).eq.'73') then
|
||||
ng=NGBASE+64
|
||||
go to 100
|
||||
endif
|
||||
|
||||
if(grid(1:1).lt.'A' .or. grid(1:1).gt.'R') text=.true.
|
||||
if(grid(2:2).lt.'A' .or. grid(2:2).gt.'R') text=.true.
|
||||
if(grid(3:3).lt.'0' .or. grid(3:3).gt.'9') text=.true.
|
||||
if(grid(4:4).lt.'0' .or. grid(4:4).gt.'9') text=.true.
|
||||
if(text) go to 100
|
||||
|
||||
call grid2deg(grid//'mm',dlong,dlat)
|
||||
long=dlong
|
||||
lat=dlat+ 90.0
|
||||
ng=((long+180)/2)*180 + lat
|
||||
go to 100
|
||||
|
||||
90 ng=NGBASE + 1
|
||||
|
||||
100 return
|
||||
end
|
||||
|
||||
47
libm65/packgrid.f90
Normal file
47
libm65/packgrid.f90
Normal file
@ -0,0 +1,47 @@
|
||||
subroutine packgrid(grid,ng,text)
|
||||
|
||||
parameter (NGBASE=180*180)
|
||||
character*4 grid
|
||||
logical text
|
||||
|
||||
text=.false.
|
||||
if(grid.eq.' ') go to 90 !Blank grid is OK
|
||||
|
||||
! Test for numerical signal report, etc.
|
||||
if(grid(1:1).eq.'-') then
|
||||
read(grid(2:3),*,err=1,end=1) n
|
||||
1 ng=NGBASE+1+n
|
||||
go to 100
|
||||
else if(grid(1:2).eq.'R-') then
|
||||
read(grid(3:4),*,err=2,end=2) n
|
||||
2 if(n.eq.0) go to 90
|
||||
ng=NGBASE+31+n
|
||||
go to 100
|
||||
else if(grid(1:2).eq.'RO') then
|
||||
ng=NGBASE+62
|
||||
go to 100
|
||||
else if(grid(1:3).eq.'RRR') then
|
||||
ng=NGBASE+63
|
||||
go to 100
|
||||
else if(grid(1:2).eq.'73') then
|
||||
ng=NGBASE+64
|
||||
go to 100
|
||||
endif
|
||||
|
||||
if(grid(1:1).lt.'A' .or. grid(1:1).gt.'R') text=.true.
|
||||
if(grid(2:2).lt.'A' .or. grid(2:2).gt.'R') text=.true.
|
||||
if(grid(3:3).lt.'0' .or. grid(3:3).gt.'9') text=.true.
|
||||
if(grid(4:4).lt.'0' .or. grid(4:4).gt.'9') text=.true.
|
||||
if(text) go to 100
|
||||
|
||||
call grid2deg(grid//'mm',dlong,dlat)
|
||||
long=dlong
|
||||
lat=dlat+ 90.0
|
||||
ng=((long+180)/2)*180 + lat
|
||||
go to 100
|
||||
|
||||
90 ng=NGBASE + 1
|
||||
|
||||
100 return
|
||||
end subroutine packgrid
|
||||
|
||||
104
libm65/packmsg.f
104
libm65/packmsg.f
@ -1,104 +0,0 @@
|
||||
subroutine packmsg(msg,dat)
|
||||
|
||||
parameter (NBASE=37*36*10*27*27*27)
|
||||
parameter (NBASE2=262178562)
|
||||
character*22 msg
|
||||
integer dat(12)
|
||||
character*12 c1,c2,c2z
|
||||
character*4 c3
|
||||
character*6 grid6
|
||||
c character*3 dxcc !Where is DXCC implemented?
|
||||
logical text1,text2,text3
|
||||
|
||||
C Convert all letters to upper case
|
||||
do i=1,22
|
||||
if(msg(i:i).ge.'a' .and. msg(i:i).le.'z')
|
||||
+ msg(i:i)= char(ichar(msg(i:i))+ichar('A')-ichar('a'))
|
||||
enddo
|
||||
|
||||
C See if it's a CQ message
|
||||
if(msg(1:3).eq.'CQ ') then
|
||||
i=3
|
||||
C ... and if so, does it have a reply frequency?
|
||||
if(msg(4:4).ge.'0' .and. msg(4:4).le.'9' .and.
|
||||
+ msg(5:5).ge.'0' .and. msg(5:5).le.'9' .and.
|
||||
+ msg(6:6).ge.'0' .and. msg(6:6).le.'9') i=7
|
||||
go to 1
|
||||
endif
|
||||
|
||||
do i=1,22
|
||||
if(msg(i:i).eq.' ') go to 1 !Get 1st blank
|
||||
enddo
|
||||
go to 10 !Consider msg as plain text
|
||||
|
||||
1 ia=i
|
||||
c1=msg(1:ia-1)
|
||||
do i=ia+1,22
|
||||
if(msg(i:i).eq.' ') go to 2 !Get 2nd blank
|
||||
enddo
|
||||
go to 10 !Consider msg as plain text
|
||||
|
||||
2 ib=i
|
||||
c2=msg(ia+1:ib-1)
|
||||
|
||||
do i=ib+1,22
|
||||
if(msg(i:i).eq.' ') go to 3 !Get 3rd blank
|
||||
enddo
|
||||
go to 10 !Consider msg as plain text
|
||||
|
||||
3 ic=i
|
||||
c3=' '
|
||||
if(ic.ge.ib+1) c3=msg(ib+1:ic)
|
||||
if(c3.eq.'OOO ') c3=' ' !Strip out the OOO flag
|
||||
call getpfx1(c1,k1,nv2)
|
||||
if(nv2.ne.0) go to 10
|
||||
call packcall(c1,nc1,text1)
|
||||
c2z=c2
|
||||
call getpfx1(c2,k2,nv2)
|
||||
call packcall(c2,nc2,text2)
|
||||
if(nv2.eq.0) then
|
||||
if(k1.lt.0 .or. k2.lt.0 .or. k1*k2.ne.0) go to 10
|
||||
if(k2.gt.0) k2=k2+450
|
||||
k=max(k1,k2)
|
||||
if(k.gt.0) then
|
||||
call k2grid(k,grid6)
|
||||
c3=grid6(:4)
|
||||
endif
|
||||
endif
|
||||
call packgrid(c3,ng,text3)
|
||||
if(nv2.eq.0 .and. (.not.text1) .and. (.not.text2) .and.
|
||||
+ (.not.text3)) go to 20
|
||||
if(nv2.gt.0) then
|
||||
if(nv2.eq.1) then
|
||||
if(c1(1:3).eq.'CQ ') nc1=262178563 + k2
|
||||
if(c1(1:4).eq.'QRZ ') nc1=264002072 + k2
|
||||
if(c1(1:3).eq.'DE ') nc1=265825581 + k2
|
||||
endif
|
||||
if(nv2.eq.2) then
|
||||
if(c1(1:3).eq.'CQ ') nc1=267649090 + k2
|
||||
if(c1(1:4).eq.'QRZ ') nc1=267698375 + k2
|
||||
if(c1(1:3).eq.'DE ') nc1=267747660 + k2
|
||||
endif
|
||||
go to 20
|
||||
endif
|
||||
|
||||
C The message will be treated as plain text.
|
||||
10 call packtext(msg,nc1,nc2,ng)
|
||||
ng=ng+32768
|
||||
|
||||
C Encode data into 6-bit words
|
||||
20 dat(1)=iand(ishft(nc1,-22),63) !6 bits
|
||||
dat(2)=iand(ishft(nc1,-16),63) !6 bits
|
||||
dat(3)=iand(ishft(nc1,-10),63) !6 bits
|
||||
dat(4)=iand(ishft(nc1, -4),63) !6 bits
|
||||
dat(5)=4*iand(nc1,15)+iand(ishft(nc2,-26),3) !4+2 bits
|
||||
dat(6)=iand(ishft(nc2,-20),63) !6 bits
|
||||
dat(7)=iand(ishft(nc2,-14),63) !6 bits
|
||||
dat(8)=iand(ishft(nc2, -8),63) !6 bits
|
||||
dat(9)=iand(ishft(nc2, -2),63) !6 bits
|
||||
dat(10)=16*iand(nc2,3)+iand(ishft(ng,-12),15) !2+4 bits
|
||||
dat(11)=iand(ishft(ng,-6),63)
|
||||
dat(12)=iand(ng,63)
|
||||
|
||||
return
|
||||
end
|
||||
104
libm65/packmsg.f90
Normal file
104
libm65/packmsg.f90
Normal file
@ -0,0 +1,104 @@
|
||||
subroutine packmsg(msg,dat)
|
||||
|
||||
parameter (NBASE=37*36*10*27*27*27)
|
||||
parameter (NBASE2=262178562)
|
||||
character*22 msg
|
||||
integer dat(12)
|
||||
character*12 c1,c2,c2z
|
||||
character*4 c3
|
||||
character*6 grid6
|
||||
! character*3 dxcc !Where is DXCC implemented?
|
||||
logical text1,text2,text3
|
||||
|
||||
! Convert all letters to upper case
|
||||
do i=1,22
|
||||
if(msg(i:i).ge.'a' .and. msg(i:i).le.'z') msg(i:i)= &
|
||||
char(ichar(msg(i:i))+ichar('A')-ichar('a'))
|
||||
enddo
|
||||
|
||||
! See if it's a CQ message
|
||||
if(msg(1:3).eq.'CQ ') then
|
||||
i=3
|
||||
! ... and if so, does it have a reply frequency?
|
||||
if(msg(4:4).ge.'0' .and. msg(4:4).le.'9' .and. &
|
||||
msg(5:5).ge.'0' .and. msg(5:5).le.'9' .and. &
|
||||
msg(6:6).ge.'0' .and. msg(6:6).le.'9') i=7
|
||||
go to 1
|
||||
endif
|
||||
|
||||
do i=1,22
|
||||
if(msg(i:i).eq.' ') go to 1 !Get 1st blank
|
||||
enddo
|
||||
go to 10 !Consider msg as plain text
|
||||
|
||||
1 ia=i
|
||||
c1=msg(1:ia-1)
|
||||
do i=ia+1,22
|
||||
if(msg(i:i).eq.' ') go to 2 !Get 2nd blank
|
||||
enddo
|
||||
go to 10 !Consider msg as plain text
|
||||
|
||||
2 ib=i
|
||||
c2=msg(ia+1:ib-1)
|
||||
|
||||
do i=ib+1,22
|
||||
if(msg(i:i).eq.' ') go to 3 !Get 3rd blank
|
||||
enddo
|
||||
go to 10 !Consider msg as plain text
|
||||
|
||||
3 ic=i
|
||||
c3=' '
|
||||
if(ic.ge.ib+1) c3=msg(ib+1:ic)
|
||||
if(c3.eq.'OOO ') c3=' ' !Strip out the OOO flag
|
||||
call getpfx1(c1,k1,nv2)
|
||||
if(nv2.ne.0) go to 10
|
||||
call packcall(c1,nc1,text1)
|
||||
c2z=c2
|
||||
call getpfx1(c2,k2,nv2)
|
||||
call packcall(c2,nc2,text2)
|
||||
if(nv2.eq.0) then
|
||||
if(k1.lt.0 .or. k2.lt.0 .or. k1*k2.ne.0) go to 10
|
||||
if(k2.gt.0) k2=k2+450
|
||||
k=max(k1,k2)
|
||||
if(k.gt.0) then
|
||||
call k2grid(k,grid6)
|
||||
c3=grid6(:4)
|
||||
endif
|
||||
endif
|
||||
call packgrid(c3,ng,text3)
|
||||
if(nv2.eq.0 .and. (.not.text1) .and. (.not.text2) .and. &
|
||||
(.not.text3)) go to 20
|
||||
if(nv2.gt.0) then
|
||||
if(nv2.eq.1) then
|
||||
if(c1(1:3).eq.'CQ ') nc1=262178563 + k2
|
||||
if(c1(1:4).eq.'QRZ ') nc1=264002072 + k2
|
||||
if(c1(1:3).eq.'DE ') nc1=265825581 + k2
|
||||
endif
|
||||
if(nv2.eq.2) then
|
||||
if(c1(1:3).eq.'CQ ') nc1=267649090 + k2
|
||||
if(c1(1:4).eq.'QRZ ') nc1=267698375 + k2
|
||||
if(c1(1:3).eq.'DE ') nc1=267747660 + k2
|
||||
endif
|
||||
go to 20
|
||||
endif
|
||||
|
||||
! The message will be treated as plain text.
|
||||
10 call packtext(msg,nc1,nc2,ng)
|
||||
ng=ng+32768
|
||||
|
||||
! Encode data into 6-bit words
|
||||
20 dat(1)=iand(ishft(nc1,-22),63) !6 bits
|
||||
dat(2)=iand(ishft(nc1,-16),63) !6 bits
|
||||
dat(3)=iand(ishft(nc1,-10),63) !6 bits
|
||||
dat(4)=iand(ishft(nc1, -4),63) !6 bits
|
||||
dat(5)=4*iand(nc1,15)+iand(ishft(nc2,-26),3) !4+2 bits
|
||||
dat(6)=iand(ishft(nc2,-20),63) !6 bits
|
||||
dat(7)=iand(ishft(nc2,-14),63) !6 bits
|
||||
dat(8)=iand(ishft(nc2, -8),63) !6 bits
|
||||
dat(9)=iand(ishft(nc2, -2),63) !6 bits
|
||||
dat(10)=16*iand(nc2,3)+iand(ishft(ng,-12),15) !2+4 bits
|
||||
dat(11)=iand(ishft(ng,-6),63)
|
||||
dat(12)=iand(ng,63)
|
||||
|
||||
return
|
||||
end subroutine packmsg
|
||||
@ -1,47 +0,0 @@
|
||||
subroutine packtext(msg,nc1,nc2,nc3)
|
||||
|
||||
parameter (MASK28=2**28 - 1)
|
||||
character*13 msg
|
||||
character*42 c
|
||||
data c/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ +-./?'/
|
||||
|
||||
nc1=0
|
||||
nc2=0
|
||||
nc3=0
|
||||
|
||||
do i=1,5 !First 5 characters in nc1
|
||||
do j=1,42 !Get character code
|
||||
if(msg(i:i).eq.c(j:j)) go to 10
|
||||
enddo
|
||||
j=37
|
||||
10 j=j-1 !Codes should start at zero
|
||||
nc1=42*nc1 + j
|
||||
enddo
|
||||
|
||||
do i=6,10 !Characters 6-10 in nc2
|
||||
do j=1,42 !Get character code
|
||||
if(msg(i:i).eq.c(j:j)) go to 20
|
||||
enddo
|
||||
j=37
|
||||
20 j=j-1 !Codes should start at zero
|
||||
nc2=42*nc2 + j
|
||||
enddo
|
||||
|
||||
do i=11,13 !Characters 11-13 in nc3
|
||||
do j=1,42 !Get character code
|
||||
if(msg(i:i).eq.c(j:j)) go to 30
|
||||
enddo
|
||||
j=37
|
||||
30 j=j-1 !Codes should start at zero
|
||||
nc3=42*nc3 + j
|
||||
enddo
|
||||
|
||||
C We now have used 17 bits in nc3. Must move one each to nc1 and nc2.
|
||||
nc1=nc1+nc1
|
||||
if(iand(nc3,32768).ne.0) nc1=nc1+1
|
||||
nc2=nc2+nc2
|
||||
if(iand(nc3,65536).ne.0) nc2=nc2+1
|
||||
nc3=iand(nc3,32767)
|
||||
|
||||
return
|
||||
end
|
||||
47
libm65/packtext.f90
Normal file
47
libm65/packtext.f90
Normal file
@ -0,0 +1,47 @@
|
||||
subroutine packtext(msg,nc1,nc2,nc3)
|
||||
|
||||
parameter (MASK28=2**28 - 1)
|
||||
character*13 msg
|
||||
character*42 c
|
||||
data c/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ +-./?'/
|
||||
|
||||
nc1=0
|
||||
nc2=0
|
||||
nc3=0
|
||||
|
||||
do i=1,5 !First 5 characters in nc1
|
||||
do j=1,42 !Get character code
|
||||
if(msg(i:i).eq.c(j:j)) go to 10
|
||||
enddo
|
||||
j=37
|
||||
10 j=j-1 !Codes should start at zero
|
||||
nc1=42*nc1 + j
|
||||
enddo
|
||||
|
||||
do i=6,10 !Characters 6-10 in nc2
|
||||
do j=1,42 !Get character code
|
||||
if(msg(i:i).eq.c(j:j)) go to 20
|
||||
enddo
|
||||
j=37
|
||||
20 j=j-1 !Codes should start at zero
|
||||
nc2=42*nc2 + j
|
||||
enddo
|
||||
|
||||
do i=11,13 !Characters 11-13 in nc3
|
||||
do j=1,42 !Get character code
|
||||
if(msg(i:i).eq.c(j:j)) go to 30
|
||||
enddo
|
||||
j=37
|
||||
30 j=j-1 !Codes should start at zero
|
||||
nc3=42*nc3 + j
|
||||
enddo
|
||||
|
||||
! We now have used 17 bits in nc3. Must move one each to nc1 and nc2.
|
||||
nc1=nc1+nc1
|
||||
if(iand(nc3,32768).ne.0) nc1=nc1+1
|
||||
nc2=nc2+nc2
|
||||
if(iand(nc3,65536).ne.0) nc2=nc2+1
|
||||
nc3=iand(nc3,32767)
|
||||
|
||||
return
|
||||
end subroutine packtext
|
||||
@ -1,13 +0,0 @@
|
||||
subroutine pctile(x,tmp,nmax,npct,xpct)
|
||||
real x(nmax),tmp(nmax)
|
||||
|
||||
do i=1,nmax
|
||||
tmp(i)=x(i)
|
||||
enddo
|
||||
call sort(nmax,tmp)
|
||||
j=nint(nmax*0.01*npct)
|
||||
if(j.lt.1) j=1
|
||||
xpct=tmp(j)
|
||||
|
||||
return
|
||||
end
|
||||
13
libm65/pctile.f90
Normal file
13
libm65/pctile.f90
Normal file
@ -0,0 +1,13 @@
|
||||
subroutine pctile(x,tmp,nmax,npct,xpct)
|
||||
real x(nmax),tmp(nmax)
|
||||
|
||||
do i=1,nmax
|
||||
tmp(i)=x(i)
|
||||
enddo
|
||||
call sort(nmax,tmp)
|
||||
j=nint(nmax*0.01*npct)
|
||||
if(j.lt.1) j=1
|
||||
xpct=tmp(j)
|
||||
|
||||
return
|
||||
end subroutine pctile
|
||||
31
libm65/set.f
31
libm65/set.f
@ -1,31 +0,0 @@
|
||||
subroutine set(a,y,n)
|
||||
real y(n)
|
||||
do i=1,n
|
||||
y(i)=a
|
||||
enddo
|
||||
return
|
||||
end
|
||||
|
||||
subroutine move(x,y,n)
|
||||
real x(n),y(n)
|
||||
do i=1,n
|
||||
y(i)=x(i)
|
||||
enddo
|
||||
return
|
||||
end
|
||||
|
||||
subroutine zero(x,n)
|
||||
real x(n)
|
||||
do i=1,n
|
||||
x(i)=0.0
|
||||
enddo
|
||||
return
|
||||
end
|
||||
|
||||
subroutine add(a,b,c,n)
|
||||
real a(n),b(n),c(n)
|
||||
do i=1,n
|
||||
c(i)=a(i)+b(i)
|
||||
enddo
|
||||
return
|
||||
end
|
||||
31
libm65/set.f90
Normal file
31
libm65/set.f90
Normal file
@ -0,0 +1,31 @@
|
||||
subroutine set(a,y,n)
|
||||
real y(n)
|
||||
do i=1,n
|
||||
y(i)=a
|
||||
enddo
|
||||
return
|
||||
end subroutine set
|
||||
|
||||
subroutine move(x,y,n)
|
||||
real x(n),y(n)
|
||||
do i=1,n
|
||||
y(i)=x(i)
|
||||
enddo
|
||||
return
|
||||
end subroutine move
|
||||
|
||||
subroutine zero(x,n)
|
||||
real x(n)
|
||||
do i=1,n
|
||||
x(i)=0.0
|
||||
enddo
|
||||
return
|
||||
end subroutine zero
|
||||
|
||||
subroutine add(a,b,c,n)
|
||||
real a(n),b(n),c(n)
|
||||
do i=1,n
|
||||
c(i)=a(i)+b(i)
|
||||
enddo
|
||||
return
|
||||
end subroutine add
|
||||
@ -1,96 +0,0 @@
|
||||
subroutine setup65
|
||||
|
||||
C Defines arrays related to the JT65 pseudo-random synchronizing pattern.
|
||||
C Executed at program start.
|
||||
|
||||
integer nprc(126)
|
||||
common/prcom/pr(126),mdat(126),mref(126,2),mdat2(126),mref2(126,2)
|
||||
|
||||
C JT65
|
||||
data nprc/
|
||||
+ 1,0,0,1,1,0,0,0,1,1,1,1,1,1,0,1,0,1,0,0,
|
||||
+ 0,1,0,1,1,0,0,1,0,0,0,1,1,1,0,0,1,1,1,1,
|
||||
+ 0,1,1,0,1,1,1,1,0,0,0,1,1,0,1,0,1,0,1,1,
|
||||
+ 0,0,1,1,0,1,0,1,0,1,0,0,1,0,0,0,0,0,0,1,
|
||||
+ 1,0,0,0,0,0,0,0,1,1,0,1,0,0,1,0,1,1,0,1,
|
||||
+ 0,1,0,1,0,0,1,1,0,0,1,0,0,1,0,0,0,0,1,1,
|
||||
+ 1,1,1,1,1,1/
|
||||
data mr2/0/ !Silence compiler warning
|
||||
|
||||
C Put the appropriate pseudo-random sequence into pr
|
||||
nsym=126
|
||||
do i=1,nsym
|
||||
pr(i)=2*nprc(i)-1
|
||||
enddo
|
||||
|
||||
C Determine locations of data and reference symbols
|
||||
k=0
|
||||
mr1=0
|
||||
do i=1,nsym
|
||||
if(pr(i).lt.0.0) then
|
||||
k=k+1
|
||||
mdat(k)=i
|
||||
else
|
||||
mr2=i
|
||||
if(mr1.eq.0) mr1=i
|
||||
endif
|
||||
enddo
|
||||
nsig=k
|
||||
|
||||
C Determine the reference symbols for each data symbol.
|
||||
do k=1,nsig
|
||||
m=mdat(k)
|
||||
mref(k,1)=mr1
|
||||
do n=1,10 !Get ref symbol before data
|
||||
if((m-n).gt.0) then
|
||||
if (pr(m-n).gt.0.0) go to 10
|
||||
endif
|
||||
enddo
|
||||
go to 12
|
||||
10 mref(k,1)=m-n
|
||||
12 mref(k,2)=mr2
|
||||
do n=1,10 !Get ref symbol after data
|
||||
if((m+n).le.nsym) then
|
||||
if (pr(m+n).gt.0.0) go to 20
|
||||
endif
|
||||
enddo
|
||||
go to 22
|
||||
20 mref(k,2)=m+n
|
||||
22 enddo
|
||||
|
||||
C Now do it all again, using opposite logic on pr(i)
|
||||
k=0
|
||||
mr1=0
|
||||
do i=1,nsym
|
||||
if(pr(i).gt.0.0) then
|
||||
k=k+1
|
||||
mdat2(k)=i
|
||||
else
|
||||
mr2=i
|
||||
if(mr1.eq.0) mr1=i
|
||||
endif
|
||||
enddo
|
||||
nsig=k
|
||||
|
||||
do k=1,nsig
|
||||
m=mdat2(k)
|
||||
mref2(k,1)=mr1
|
||||
do n=1,10
|
||||
if((m-n).gt.0) then
|
||||
if (pr(m-n).lt.0.0) go to 110
|
||||
endif
|
||||
enddo
|
||||
go to 112
|
||||
110 mref2(k,1)=m-n
|
||||
112 mref2(k,2)=mr2
|
||||
do n=1,10
|
||||
if((m+n).le.nsym) then
|
||||
if (pr(m+n).lt.0.0) go to 120
|
||||
endif
|
||||
enddo
|
||||
go to 122
|
||||
120 mref2(k,2)=m+n
|
||||
122 enddo
|
||||
|
||||
return
|
||||
end
|
||||
96
libm65/setup65.f90
Normal file
96
libm65/setup65.f90
Normal file
@ -0,0 +1,96 @@
|
||||
subroutine setup65
|
||||
|
||||
! Defines arrays related to the JT65 pseudo-random synchronizing pattern.
|
||||
! Executed at program start.
|
||||
|
||||
integer nprc(126)
|
||||
common/prcom/pr(126),mdat(126),mref(126,2),mdat2(126),mref2(126,2)
|
||||
|
||||
! JT65
|
||||
data nprc/ &
|
||||
1,0,0,1,1,0,0,0,1,1,1,1,1,1,0,1,0,1,0,0, &
|
||||
0,1,0,1,1,0,0,1,0,0,0,1,1,1,0,0,1,1,1,1, &
|
||||
0,1,1,0,1,1,1,1,0,0,0,1,1,0,1,0,1,0,1,1, &
|
||||
0,0,1,1,0,1,0,1,0,1,0,0,1,0,0,0,0,0,0,1, &
|
||||
1,0,0,0,0,0,0,0,1,1,0,1,0,0,1,0,1,1,0,1, &
|
||||
0,1,0,1,0,0,1,1,0,0,1,0,0,1,0,0,0,0,1,1, &
|
||||
1,1,1,1,1,1/
|
||||
data mr2/0/ !Silence compiler warning
|
||||
|
||||
! Put the appropriate pseudo-random sequence into pr
|
||||
nsym=126
|
||||
do i=1,nsym
|
||||
pr(i)=2*nprc(i)-1
|
||||
enddo
|
||||
|
||||
! Determine locations of data and reference symbols
|
||||
k=0
|
||||
mr1=0
|
||||
do i=1,nsym
|
||||
if(pr(i).lt.0.0) then
|
||||
k=k+1
|
||||
mdat(k)=i
|
||||
else
|
||||
mr2=i
|
||||
if(mr1.eq.0) mr1=i
|
||||
endif
|
||||
enddo
|
||||
nsig=k
|
||||
|
||||
! Determine the reference symbols for each data symbol.
|
||||
do k=1,nsig
|
||||
m=mdat(k)
|
||||
mref(k,1)=mr1
|
||||
do n=1,10 !Get ref symbol before data
|
||||
if((m-n).gt.0) then
|
||||
if (pr(m-n).gt.0.0) go to 10
|
||||
endif
|
||||
enddo
|
||||
go to 12
|
||||
10 mref(k,1)=m-n
|
||||
12 mref(k,2)=mr2
|
||||
do n=1,10 !Get ref symbol after data
|
||||
if((m+n).le.nsym) then
|
||||
if (pr(m+n).gt.0.0) go to 20
|
||||
endif
|
||||
enddo
|
||||
go to 22
|
||||
20 mref(k,2)=m+n
|
||||
22 enddo
|
||||
|
||||
! Now do it all again, using opposite logic on pr(i)
|
||||
k=0
|
||||
mr1=0
|
||||
do i=1,nsym
|
||||
if(pr(i).gt.0.0) then
|
||||
k=k+1
|
||||
mdat2(k)=i
|
||||
else
|
||||
mr2=i
|
||||
if(mr1.eq.0) mr1=i
|
||||
endif
|
||||
enddo
|
||||
nsig=k
|
||||
|
||||
do k=1,nsig
|
||||
m=mdat2(k)
|
||||
mref2(k,1)=mr1
|
||||
do n=1,10
|
||||
if((m-n).gt.0) then
|
||||
if (pr(m-n).lt.0.0) go to 110
|
||||
endif
|
||||
enddo
|
||||
go to 112
|
||||
110 mref2(k,1)=m-n
|
||||
112 mref2(k,2)=mr2
|
||||
do n=1,10
|
||||
if((m+n).le.nsym) then
|
||||
if (pr(m+n).lt.0.0) go to 120
|
||||
endif
|
||||
enddo
|
||||
go to 122
|
||||
120 mref2(k,2)=m+n
|
||||
122 enddo
|
||||
|
||||
return
|
||||
end subroutine setup65
|
||||
@ -1,4 +0,0 @@
|
||||
subroutine sort(n,arr)
|
||||
call ssort(arr,tmp,n,1)
|
||||
return
|
||||
end
|
||||
6
libm65/sort.f90
Normal file
6
libm65/sort.f90
Normal file
@ -0,0 +1,6 @@
|
||||
subroutine sort(n,arr)
|
||||
|
||||
call ssort(arr,tmp,n,1)
|
||||
|
||||
return
|
||||
end subroutine sort
|
||||
Loading…
Reference in New Issue
Block a user