c Copyright (C) 2008-2014 Vincent Eymet c c KDISTRIBUTION is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3, or (at your option) c any later version. c KDISTRIBUTION is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c You should have received a copy of the GNU General Public License c along with KDISTRIBUTION; if not, see c subroutine find_free_process(free,nproc,fpf,proc) implicit none include 'max.inc' c c Purpose: to find 'proc', the index of a free child process c c Input: c + free: 0/1 value for each child process (0: busy process, 1: free process) c + nproc: number of child processes c c Output: c + fpf: 0 if no free child process found; 1 otherwise c + proc: index of the free child process found, if fpf=1 c integer free(1:Nproc_mx) integer proc,nproc,fpf c label integer strlen character*(Nchar_mx) label label='subroutine find_free_process' fpf=0 do proc=1,nproc if (free(proc).eq.1) then fpf=1 goto 123 endif enddo 123 continue return end subroutine stopped_processes(free,nproc,nsp) implicit none include 'max.inc' c c Purpose: to identify the number of child processes that have been stopped c c Input: c + free: array of free processes (a value of 2 means that the corresponding child process has been stopped) c + nproc: number of child processes c c Output: c + nsp: number of child processes that have been stopped c integer free(1:Nproc_mx) integer proc,nproc,nsp c label integer strlen character*(Nchar_mx) label label='subroutine stopped_processes' nsp=0 do proc=1,nproc if (free(proc).eq.2) then nsp=nsp+1 endif enddo return end subroutine find_min(v1,v2,vmin) implicit none include 'max.inc' double precision v1,v2,vmin c label integer strlen character*(Nchar_mx) label label='subroutine find_min' vmin=v1 if (v2.lt.v1) then vmin=v2 endif return end subroutine rmfile(tfile) implicit none include 'max.inc' c Purpose: to erase the specified file character*(Nchar_mx) tfile,command,path c label integer strlen character*(Nchar_mx) label label='subroutine rmfile' path='./' command='rm -rf ' & //path(1:strlen(path)) & //tfile(1:strlen(tfile)) call exec(command) return end subroutine read_eps12(pfile,eps1,eps2) implicit none include 'max.inc' include 'formats.inc' integer ios double precision eps1,eps2 character*(Nchar_mx) pfile c label integer strlen character*(Nchar_mx) label label='subroutine read_eps12' open(10,file=pfile(1:strlen(pfile)),status='old',iostat=ios) if (ios.ne.0) then ! file not found write(*,*) 'Warning: file not found:' write(*,*) pfile(1:strlen(pfile)) write(*,*) 'Uncertainties over k(g) will be set to zero' eps1=0.0D+0 eps2=0.0D+0 else read(10,*) read(10,50) eps1,eps2 endif close(10) return end subroutine abcd_coeffs(nu1,nu2,k0,k1,k2,z1,z2,a,b,c,d) implicit none include 'max.inc' double precision nu1,nu2,k0,k1,k2,z1,z2 double precision a,b,c,d c label integer strlen character*(Nchar_mx) label label='subroutine abcd_coeffs' a=(z2-z1)/(6.0D+0*(nu2-nu1)) b=(z1*nu2-z2*nu1)/(2.0D+0*(nu2-nu1)) c=(z2*nu1**2.0D+0-z1*nu2**2.0D+0) & /(2.0D+0*(nu2-nu1)) & +(k2-k1)/(nu2-nu1) & +(nu2-nu1)*(z1-z2)/6.0D+0 d=(z1*nu2**3.0D+0-z2*nu1**3.0D+0) & /(6.0D+0*(nu2-nu1)) & +(k1*nu2-k2*nu1)/(nu2-nu1) & +(nu2-nu1)*(nu1*z2-nu2*z1)/6.0D+0 & -k0 return end subroutine identify_solution(n,x,nu1,nu2,k0,k1,k2,z1,z2,nu,nuf) implicit none include 'max.inc' integer n,nuf double precision x(1:3) double precision nu1,nu2,k0,k1,k2,z1,z2,nu integer i,nvalid,valid(1:3) double precision dk,kr double precision S,k parameter(kr=1.0D+3) c label integer strlen character*(Nchar_mx) label label='subroutine identify_solution' nvalid=0 do i=1,n if ((x(i).ge.nu1).and.(x(i).le.nu2)) then nvalid=nvalid+1 valid(nvalid)=i endif enddo if (nvalid.eq.0) then dk=dabs(k2-k1)/kr if (dabs(k0-k1).le.dk) then nvalid=1 valid(1)=1 x(1)=nu1 c nuf=1 c goto 123 endif if (dabs(k0-k2).le.dk) then nvalid=1 valid(1)=1 x(1)=nu2 c nuf=1 c goto 123 endif endif if (nvalid.ne.1) then nuf=0 c write(*,*) 'Error from routine ',label(1:strlen(label)),':' c write(*,*) 'Number of valid solutions:',nvalid c write(*,*) 'nu1=',nu1,' nu2=',nu2 c write(*,*) 'n=',n c do i=1,n c write(*,*) 'x(',i,')=',x(i) c enddo c stop else nuf=1 nu=x(valid(1)) k=S(z1,z2,nu1,nu2,k1,k2,nu) if (k.ne.k0) then c write(*,*) 'Error from routine ', c & label(1:strlen(label)),':' c write(*,*) 'Solution found:' c write(*,*) 'S(',nu,')=',k c write(*,*) 'k0=',k0 call dichotomy(nu1,nu2,k1,k2,k0,z1,z2,nu) c write(*,*) 'S(',nut,')=',S(z1,z2,nu1,nu2,k1,k2,nut) c stop endif endif 123 continue c Debug if ((nuf.ne.0).and.(nuf.ne.1)) then write(*,*) 'warning, nuf=',nuf endif c Debug return end subroutine std5(val,moy,std,cl) implicit none include 'max.inc' double precision val(1:5),inc,std double precision sum,sum2,moy integer j,n,cl c label integer strlen character*(Nchar_mx) label label='subroutine std5' n=5 sum=0.0D+0 sum2=0.0D+0 do j=1,n sum=sum+val(j) sum2=sum2+val(j)**2.0D+0 enddo moy=sum/n inc=sum2/n-moy**2.0D+0 std=dsqrt(dabs(inc)) cl=1 do j=1,n if (dabs(val(j)-moy).gt.1.0D-7) then cl=0 endif enddo 123 continue return end