Starting to insert mutex lockouts around Fortran I/O

git-svn-id: svn+ssh://svn.code.sf.net/p/wsjt/wsjt/branches/map65@1298 ab8295b8-cf94-4d9e-aec4-7959e3be5d79

Makefile.MinGW

@@ -3,7 +3,7 @@
 CC = /mingw/bin/gcc
 FC = g95
 CFLAGS = -I. -fPIC
-FFLAGS = -Wall -Wno-precision-loss -fbounds-check -fPIC
+FFLAGS = -Wall -Wno-precision-loss -fbounds-check -fPIC -fno-second-underscore
 
 .f.o:
 	${FC} ${CPPFLAGS} ${FFLAGS} -c -o ${<:.f=.o} $<
@@ -19,7 +19,7 @@ SRCF90 = a2d.f90 astro0.f90 audio_init.f90 azdist0.f90 \
 	runqqq.f90 fivehz.f90 flushqqq.f90 \
 	rfile.f90 rfile3a.F90 spec.f90 map65a.F90 display.F90 \
 	getfile.f90 getfile2.f90 recvpkt.f90 savetf2.F90 \
-	symspec.f90 sec_midn.F90 getdphi.f90
+	symspec.f90 sec_midn.F90 getdphi.f90 thnix.f90
 
 SRCCOM = datcom.f90 gcom1.f90 gcom2.f90 gcom3.f90 gcom4.f90 spcom.f90
 
@@ -38,8 +38,7 @@ SRCF77 = indexx.f gen65.f chkmsg.f \
 
 SRC2F77 = four2a.f filbig.f
 
-SRCS2C   = ptt.c igray.c wrapkarn.c cutil.c \
+SRCS2C   = ptt.c igray.c wrapkarn.c cutil.c start_portaudio.c fthread.c
-	start_portaudio.c
 
 OBJF77 = ${SRCF77:.f=.o}
 
@@ -62,7 +61,7 @@ map65.spec: map65.py astro.py g.py options.py palettes.py smeter.py specjt.py
 	--icon wsjt.ico --tk --onefile map65.py
 
 deep65.o: deep65.F
-	$(FC) -c -O0 -Wall -fPIC deep65.F
+	$(FC) -c -O0 -Wall -fPIC -fno-second-underscore deep65.F
 
 jtaudio.o: jtaudio.c
 	$(CC) -c -DWin32 -o jtaudio.o jtaudio.c
@@ -97,6 +96,6 @@ plrr_subs.o: plrr_subs_win.c
 .PHONY : clean
 
 clean:
-	rm *.o Audio.pyd map65.spec MAP65.EXE 
+	rm -f *.o Audio.pyd map65.spec MAP65.EXE 
 
 

a2d.f90

@@ -1,4 +1,3 @@
-!---------------------------------------------------- a2d
 subroutine a2d(iarg)
 
 ! Start the PortAudio streams for audio input and output.
@@ -9,6 +8,7 @@ subroutine a2d(iarg)
 ! This call does not normally return, as the background portion of
 ! JTaudio goes into a test-and-sleep loop.
 
+  call cs_lock('a2d')
   write(*,1000)
 1000 format('Using Linrad for input, PortAudio for output.')
   idevout=ndevout
@@ -21,6 +21,7 @@ subroutine a2d(iarg)
   if(idevout.lt.0 .or. idevout.ge.numdevs) idevout=ndefout
   if(idevout.eq.0) idevout=ndefout
   idevin=0
+  call cs_unlock
   ierr=jtaudio(idevin,idevout,y1,y2,NMAX,iwrite,iwave,nwave,    &
        11025,NSPB,TRPeriod,TxOK,ndebug,Transmitting,            &
        Tsec,ngo,nmode,tbuf,ibuf,ndsec)

astro.F

@@ -24,11 +24,12 @@ C  NB: may want to smooth the Tsky map to 10 degrees or so.
       if(first) then
 	do i=80,1,-1
 	   if(ichar(AppDir(i:i)).ne.0 .and. 
-     +            ichar(AppDir(i:i)).ne.32) goto 1
+     +            ichar(AppDir(i:i)).ne.32) go to 1
 	enddo
  1	lenappdir=i
         call zero(nsky,180*180)
 	fname=Appdir(1:lenappdir)//'/TSKY.DAT'
+        call cs_lock('astro')
 #ifdef CVF
         open(13,file=fname,status='old',form='binary',err=10)
         read(13) nsky
@@ -40,9 +41,11 @@ C  NB: may want to smooth the Tsky map to 10 degrees or so.
 #endif
         ltsky=.true.
         first=.false.
+        call cs_unlock
       endif
       go to 20
  10   ltsky=.false.
+      call cs_unlock
 
  20   call grid2deg(MyGrid,elon,lat)
       lon=-elon

astro0.F90

@@ -1,4 +1,3 @@
-!--------------------------------------------------- astro0
 subroutine astro0(nyear,month,nday,uth8,nfreq,grid,cauxra,cauxdec,       &
      AzSun8,ElSun8,AzMoon8,ElMoon8,AzMoonB8,ElMoonB8,ntsky,ndop,ndop00,  &
      dbMoon8,RAMoon8,DecMoon8,HA8,Dgrd8,sd8,poloffset8,xnr8,dfdt,dfdt0,  &
@@ -16,6 +15,7 @@ subroutine astro0(nyear,month,nday,uth8,nfreq,grid,cauxra,cauxdec,       &
   data uth8z/0.d0/,imin0/-99/
   save
 
+  call cs_lock('astro0a')
   auxra=0.
   i=index(cauxra,':')
   if(i.eq.0) then
@@ -48,6 +48,7 @@ subroutine astro0(nyear,month,nday,uth8,nfreq,grid,cauxra,cauxdec,       &
   if(mode.eq.'JT6M') nmode=4
   uth=uth8
 
+  call cs_unlock
   call astro(AppDir,nyear,month,nday,uth,nfreq,hisgrid,2,nmode,1,    &
        AzSun,ElSun,AzMoon,ElMoon,ntsky,doppler00,doppler,            &
        dbMoon,RAMoon,DecMoon,HA,Dgrd,sd,poloffset,xnr,auxra,auxdec,  &
@@ -96,6 +97,7 @@ subroutine astro0(nyear,month,nday,uth8,nfreq,grid,cauxra,cauxdec,       &
   isec=3600*uth8
 
   if(isec.ne.isec0 .and. ndecoding.eq.0) then
+     call cs_lock('astro0b')
      ih=uth8
      im=mod(imin,60)
      is=mod(isec,60)
@@ -113,6 +115,7 @@ subroutine astro0(nyear,month,nday,uth8,nfreq,grid,cauxra,cauxdec,       &
      call flushqqq(14)
      nsetftx=0
      isec0=isec
+     call cs_unlock
   endif
 
   return

decode1.F90

@@ -55,9 +55,11 @@ subroutine decode1(iarg)
      ns0=999999
   endif
   if(n.lt.ns0 .and. utcdate(1:1).eq.'2') then
+     call cs_lock('decode1a')
      write(21,1001) utcdate(:11)
 1001 format(/'UTC Date: ',a11/'---------------------')
      ns0=n
+     call cs_unlock
   endif
 
   if(transmitting.eq.1 .and. (sending.ne.sending0 .or.       &
@@ -67,9 +69,11 @@ subroutine decode1(iarg)
      is=mod(n,60)
      cshort='           '
      if(sendingsh.eq.1) cshort='(Shorthand)'
+     call cs_lock('decode1b')
      write(21,1010) ih,im,is,mode,sending,cshort
 1010 format(3i2.2,'  Transmitting: ',a6,2x,a28,2x,a11)
      call flushqqq(21)
+     call cs_unlock
      sending0=sending
      sendingsh0=sendingsh
      mode0=mode

deep65.F

@@ -34,6 +34,8 @@
       modified=0                              !@@@
       if(mycall.eq.mycall0 .and. hiscall.eq.hiscall0 .and. 
      +   hisgrid.eq.hisgrid0 .and. modified.eq.modified0) go to 30
+
+      call cs_lock('deep65a')
       rewind 23
       k=0
       icall=0
@@ -100,7 +102,10 @@ C  Insert CQ message
          enddo
  10      continue
       enddo
- 20   ntot=k
+
+ 20   continue
+      call cs_unlock
+      ntot=k
       neme0=neme
 
  30   mycall0=mycall
@@ -141,8 +146,11 @@ C  Insert CQ message
       enddo
 
 C  ### DO NOT REMOVE ### 
+      call cs_lock('deep65b')
       rewind 77
       write(77,*) p1,p2
+      call cs_unlock
+
 C  ### Works OK without it (in both Windows and Linux) if compiled 
 C  ### without optimization.  However, in Windows this is a colossal 
 C  ### pain because of the way McMillan Installer wants to run the 

fthread.c

@@ -0,0 +1,74 @@
+/*
+* fthread.c
+*
+* pthread library interface to Fortran, for OSs supporting pthreads
+*
+* Adapted from code by V. Ganesh
+*/
+#include <stdio.h>
+#include <pthread.h>
+
+// Create a new fortran thread through a subroutine.
+void fthread_create_(void *(*thread_func)(void *), pthread_t *theThread) 
+{
+  pthread_create(theThread, NULL, thread_func, NULL);
+} 
+
+/*
+// Yield control to other threads
+void fthread_yield_() 
+{
+  pthread_yield();
+}
+*/
+
+// Return my own thread ID
+pthread_t fthread_self_() 
+{
+  return pthread_self();
+} 
+
+// Lock the execution of all threads until we have the mutex
+int fthread_mutex_lock_(pthread_mutex_t **theMutex) 
+{
+  return(pthread_mutex_lock(*theMutex));
+}
+
+int fthread_mutex_trylock_(pthread_mutex_t **theMutex) 
+{
+  return(pthread_mutex_trylock(*theMutex));
+}
+
+// Unlock the execution of all threads that were stopped by this mutex
+void fthread_mutex_unlock_(pthread_mutex_t **theMutex) 
+{
+  pthread_mutex_unlock(*theMutex);
+}
+
+// Get a new mutex object
+void fthread_mutex_init_(pthread_mutex_t **theMutex) 
+{
+  *theMutex = (pthread_mutex_t *) malloc(sizeof(pthread_mutex_t));
+  pthread_mutex_init(*theMutex, NULL);
+}
+
+// Release a mutex object
+void fthread_mutex_destroy_(pthread_mutex_t **theMutex) 
+{
+  pthread_mutex_destroy(*theMutex);
+  free(*theMutex);
+}
+
+// Waits for thread ID to join
+void fthread_join(pthread_t *theThread) 
+{
+  int value = 0;
+  pthread_join(*theThread, (void **)&value);
+}
+
+// Exit from a thread
+void fthread_exit_(void *status) 
+{
+  pthread_exit(status);
+}
+

ftn_init.F90

@@ -30,7 +30,8 @@ subroutine ftn_init
   include 'gcom3.f90'
   include 'gcom4.f90'
 
-!  print*,'ftn_init.F90 nport=', nport, 'pttport=', pttport
+  call cs_init
+  call cs_lock('ftn_init')
   i=ptt(nport,pttport,0,iptt)                       !Clear the PTT line
   addpfx='    '
   nrw26=0
@@ -146,7 +147,7 @@ subroutine ftn_init
   open(29,file=appdir(:iz)//'/debug.txt',status='unknown')
 #endif
 
-
+  call cs_unlock
   return
 
 910 print*,'Error opening DECODED.TXT'

map65.py

@@ -1,4 +1,4 @@
-#----------------------------------------------------------------------- MAP65
+#------------------------------------------------------------------------ MAP65
 # $Date$ $Revision$
 #
 from Tkinter import *

thcvf.f90

@@ -0,0 +1,64 @@
+subroutine cs_init
+  use dfmt
+  type (RTL_CRITICAL_SECTION) ncrit1
+  character*12 csub0
+  common/mtxcom/ltrace,mtx,mtxstate,csub0
+  ltrace=1
+  mtx=loc(ncrit1)
+  mtxstate=0
+  csub0='**unlocked**'
+  call InitializeCriticalSection(mtx)
+  return
+end subroutine cs_init
+
+subroutine cs_destroy
+  use dfmt
+  type (RTL_CRITICAL_SECTION) ncrit1
+  character*12 csub0
+  common/mtxcom/ltrace,mtx,mtxstate,csub0
+  call DeleteCriticalSection(mtx)
+  return
+end subroutine cs_destroy
+
+subroutine th_create(sub)
+  use dfmt
+  external sub
+  ith=CreateThread(0,0,sub,0,0,id)
+  return
+end subroutine th_create
+
+subroutine th_exit
+  use dfmt
+  ncode=0
+  call ExitThread(ncode)
+  return
+end subroutine th_exit
+
+subroutine cs_lock(csub)
+  use dfmt
+  character*(*) csub
+  character*12 csub0
+  common/mtxcom/ltrace,mtx,mtxstate,csub0
+  n=TryEnterCriticalSection(mtx)
+  if(n.eq.0) then
+! Another thread has already locked the mutex
+     call EnterCriticalSection(mtx)
+     iz=index(csub0,' ')
+     if(ltrace.ge.1) print*,'"',csub,'" requested the mutex when "',  &
+          csub0(:iz-1),'" owned it.'
+  endif
+  mtxstate=1
+  csub0=csub
+  if(ltrace.ge.3) print*,'Mutex locked by ',csub
+  return
+end subroutine cs_lock
+
+subroutine cs_unlock
+  use dfmt
+  character*12 csub0
+  common/mtxcom/ltrace,mtx,mtxstate,csub0
+  mtxstate=0
+  if(ltrace.ge.3) print*,'Mutex unlocked'
+  call LeaveCriticalSection(mtx)
+  return
+end subroutine cs_unlock

thnix.f90

@@ -0,0 +1,54 @@
+subroutine cs_init
+  character*12 csub0
+  common/mtxcom/ltrace,mtx,mtxstate,csub0
+  ltrace=0
+  mtxstate=0
+  csub0='**unlocked**'
+  call fthread_mutex_init(mtx)
+  return
+end subroutine cs_init
+
+subroutine cs_destroy
+  character*12 csub0
+  common/mtxcom/ltrace,mtx,mtxstate,csub0
+  call fthread_mutex_destroy(mtx)
+  return
+end subroutine cs_destroy
+
+subroutine th_create(sub)
+  call fthread_create(sub,id)
+  return
+end subroutine th_create
+
+subroutine th_exit
+  call fthread_exit
+  return
+end subroutine th_exit
+
+subroutine cs_lock(csub)
+  character*(*) csub
+  character*12 csub0
+  integer fthread_mutex_lock,fthread_mutex_trylock
+  common/mtxcom/ltrace,mtx,mtxstate,csub0
+  n=fthread_mutex_trylock(mtx)
+  if(n.ne.0) then
+! Another thread has already locked the mutex
+     n=fthread_mutex_lock(mtx)
+     iz=index(csub0,' ')
+     if(ltrace.ge.1) print*,'"',csub,'" requested mutex when "',   &
+          csub0(:iz-1),'" owned it.'
+  endif
+  mtxstate=1
+  csub0=csub
+  if(ltrace.ge.3) print*,'Mutex locked by ',csub
+  return
+end subroutine cs_lock
+
+subroutine cs_unlock
+  character*12 csub0
+  common/mtxcom/ltrace,mtx,mtxstate,csub0
+  if(ltrace.ge.3) print*,'Mutex unlocked,',ltrace,mtx,mtxstate,csub0
+  mtxstate=0
+  call fthread_mutex_unlock(mtx)
+  return
+end subroutine cs_unlock