mirror of
https://github.com/saitohirga/WSJT-X.git
synced 2024-11-22 20:28:42 -05:00
59 lines
1.3 KiB
Fortran
59 lines
1.3 KiB
Fortran
|
program free_text
|
||
|
|
character*13 c13,w
|
||
|
|
character*71 f71
|
||
|
|
character*42 c
|
||
|
|
character*1 qa(10),qb(10)
|
||
|
|
data c/' 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ+-./?'/
|
||
|
|
c13='TNX BOB 73 GL' !Redefine as needed
|
||
|
|
call mp_short_init
|
||
|
|
qa=char(0)
|
||
|
|
w=adjustr(c13)
|
||
|
|
do i=1,13
|
||
|
|
j=index(c,w(i:i))-1
|
||
|
|
if(j.lt.0) j=0
|
||
|
|
call mp_short_mult(qb,qa(2:10),9,42) !qb(1:9)=42*qa(2:9)
|
||
|
|
call mp_short_add(qa,qb(2:10),9,j) !qa(1:9)=qb(2:9)+j
|
||
|
|
enddo
|
||
|
|
write(f71,1000) qa(2:10)
|
||
|
|
1000 format(b7.7,8b8.8)
|
||
|
|
write(*,1010) c13,f71
|
||
|
|
1010 format('Free text: ',a13/'f71: ',a71)
|
||
|
|
end program free_text
|
||
|
|
|
||
|
|
subroutine mp_short_ops(w,u)
|
||
|
|
! Multi-precision arithmetic with storage in character arrays.
|
||
|
|
character*1 w(*),u(*)
|
||
|
|
integer i,ireg,j,n,ir,iv,ii1,ii2
|
||
|
|
character*1 creg(4)
|
||
|
|
save ii1,ii2
|
||
|
|
equivalence (ireg,creg)
|
||
|
|
|
||
|
|
entry mp_short_init
|
||
|
|
ireg=256*ichar('2')+ichar('1')
|
||
|
|
do j=1,4
|
||
|
|
if (creg(j).eq.'1') ii1=j
|
||
|
|
if (creg(j).eq.'2') ii2=j
|
||
|
|
enddo
|
||
|
|
return
|
||
|
|
|
||
|
|
entry mp_short_add(w,u,n,iv)
|
||
|
|
ireg=256*iv
|
||
|
|
do j=n,1,-1
|
||
|
|
ireg=ichar(u(j))+ichar(creg(ii2))
|
||
|
|
w(j+1)=creg(ii1)
|
||
|
|
enddo
|
||
|
|
w(1)=creg(ii2)
|
||
|
|
return
|
||
|
|
|
||
|
|
entry mp_short_mult(w,u,n,iv)
|
||
|
|
ireg=0
|
||
|
|
do j=n,1,-1
|
||
|
|
ireg=ichar(u(j))*iv+ichar(creg(ii2))
|
||
|
|
w(j+1)=creg(ii1)
|
||
|
|
enddo
|
||
|
|
w(1)=creg(ii2)
|
||
|
|
return
|
||
|
|
|
||
|
|
return
|
||
|
|
end subroutine mp_short_ops
|