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