diff --git a/.git-blame-ignore-revs b/.git-blame-ignore-revs new file mode 100644 index 0000000..3e9f837 --- /dev/null +++ b/.git-blame-ignore-revs @@ -0,0 +1,2 @@ +# fprettify (#15) +579c967b339ca163fbaa4487ca37e04251bc17aa diff --git a/.github/azure-pipelines.yaml b/.github/azure-pipelines.yaml index dcc3ec1..d0589a5 100644 --- a/.github/azure-pipelines.yaml +++ b/.github/azure-pipelines.yaml @@ -20,4 +20,5 @@ extends: IMAGE: private COVERAGE: true TAPENADE: true + TAPENADE_VERSION: "3.16" FPRETTIFY: true diff --git a/common_CS.mk b/common_CS.mk index edc0731..fb9d0b4 100644 --- a/common_CS.mk +++ b/common_CS.mk @@ -39,8 +39,15 @@ MAKE_CLEAN_ARGUMENTS = *~ *.o *.mod *.il *.stb c_* *.a # * * # ****************************************************************** -FF90_ALL_FLAGS = -I$(MODDIR) $(CGNS_INCLUDE_FLAGS) \ - $(FF90_GEN_FLAGS) $(FF90_OPT_FLAGS) -DUSE_COMPLEX - -CC_ALL_FLAGS = -I$(MODDIR) $(CGNS_INCLUDE_FLAGS) \ - $(CC_GEN_FLAGS) $(CC_OPT_FLAGS) +FF77_ALL_FLAGS = -I$(MODDIR) \ + $(CGNS_INCLUDE_FLAGS) \ + $(FF77_FLAGS) + +FF90_ALL_FLAGS = -I$(MODDIR) \ + $(CGNS_INCLUDE_FLAGS) \ + $(FF90_FLAGS) \ + -DUSE_COMPLEX + +CC_ALL_FLAGS = -I$(MODDIR) \ + $(CGNS_INCLUDE_FLAGS) \ + $(C_FLAGS) diff --git a/common_real.mk b/common_real.mk index e05ab69..0238661 100644 --- a/common_real.mk +++ b/common_real.mk @@ -39,8 +39,14 @@ MAKE_CLEAN_ARGUMENTS = *~ *.o *.mod *.il *.stb c_* *.a # * * # ****************************************************************** -FF90_ALL_FLAGS = -I$(MODDIR) $(CGNS_INCLUDE_FLAGS) \ - $(FF90_GEN_FLAGS) $(FF90_OPT_FLAGS) +FF77_ALL_FLAGS = -I$(MODDIR) \ + $(CGNS_INCLUDE_FLAGS) \ + $(FF77_FLAGS) -CC_ALL_FLAGS = -I$(MODDIR) $(CGNS_INCLUDE_FLAGS) \ - $(CC_GEN_FLAGS) $(CC_OPT_FLAGS) +FF90_ALL_FLAGS = -I$(MODDIR) \ + $(CGNS_INCLUDE_FLAGS) \ + $(FF90_FLAGS) + +CC_ALL_FLAGS = -I$(MODDIR) \ + $(CGNS_INCLUDE_FLAGS) \ + $(C_FLAGS) diff --git a/config/defaults/config_LINUX_GFORTRAN.mk b/config/defaults/config_LINUX_GFORTRAN.mk index cb4af9e..1f881d1 100644 --- a/config/defaults/config_LINUX_GFORTRAN.mk +++ b/config/defaults/config_LINUX_GFORTRAN.mk @@ -14,11 +14,9 @@ CGNS_INCLUDE_FLAGS=-I$(CGNS_HOME)/include CGNS_LINKER_FLAGS=-L$(CGNS_HOME)/lib -lcgns # ------- Define Compiler Flags ---------------------------------------- -FF90_GEN_FLAGS = -fPIC -g -fbounds-check -CC_GEN_FLAGS = -fPIC - -FF90_OPT_FLAGS = -fPIC -fdefault-real-8 -O2 -fdefault-double-8 -CC_OPT_FLAGS = -O2 +FF77_FLAGS = -fPIC -O2 -fdefault-real-8 -fdefault-double-8 -g -fbounds-check +FF90_FLAGS = ${FF77_FLAGS} -std=f2008 +C_FLAGS = -fPIC -O2 # ------- Define Archiver and Flags ----------------------------------- AR = ar diff --git a/config/defaults/config_LINUX_INTEL.mk b/config/defaults/config_LINUX_INTEL.mk index e95c0a8..6d713a5 100644 --- a/config/defaults/config_LINUX_INTEL.mk +++ b/config/defaults/config_LINUX_INTEL.mk @@ -14,11 +14,9 @@ CGNS_INCLUDE_FLAGS=-I$(CGNS_HOME)/include CGNS_LINKER_FLAGS=-L$(CGNS_HOME)/lib -lcgns # ------- Define Compiler Flags ---------------------------------------- -FF90_GEN_FLAGS = -DHAS_ISNAN -fPIC -r8 -O2 -g -CC_GEN_FLAGS = -DHAS_ISNAN -O -fPIC - -FF90_OPT_FLAGS = -DHAS_ISNAN -fPIC -r8 -O2 -g -CC_OPT_FLAGS = -DHAS_ISNAN -O -fPIC +FF77_FLAGS = -fPIC -r8 -O2 -g +FF90_FLAGS = ${FF77_FLAGS} -std08 +C_FLAGS = -fPIC -O2 # ------- Define Archiver and Flags ----------------------------------- AR = ar @@ -26,7 +24,7 @@ AR_FLAGS = -rvs # ------- Define Linker Flags ------------------------------------------ LINKER = $(FF90) -LINKER_FLAGS = -nofor_main +LINKER_FLAGS = -nofor-main # Define potentially different python, python-config and f2py executables: PYTHON = python diff --git a/rulesSources.mk b/rulesSources.mk index be6e93d..e5495d8 100644 --- a/rulesSources.mk +++ b/rulesSources.mk @@ -19,13 +19,7 @@ @echo %.o: %.f - $(FF90) $(FF90_ALL_FLAGS) -c $< -o $(OBJDIR)/$(@F) - @echo - @echo " --- Compiled $*.f successfully ---" - @echo - -%.o: %.F - $(FF90) $(FF90_ALL_FLAGS) -c $< -o $(OBJDIR)/$(@F) + $(FF90) $(FF77_ALL_FLAGS) -c $< -o $(OBJDIR)/$(@F) @echo @echo " --- Compiled $*.f successfully ---" @echo diff --git a/src/ADT/adtLocalSearch.F90 b/src/ADT/adtLocalSearch.F90 index eb32aa3..c18057a 100644 --- a/src/ADT/adtLocalSearch.F90 +++ b/src/ADT/adtLocalSearch.F90 @@ -1603,7 +1603,7 @@ subroutine intersectionTreeSearch(jj, inpBBox, & ! * * ! **************************************************************** ! - use Utilities ! ../utilities/Utilities.F90 + use utilities ! ../utilities/utilities.F90 implicit none ! ! Subroutine arguments. @@ -1726,7 +1726,7 @@ subroutine intersectionTreeSearch(jj, inpBBox, & BBoxB = xBBox(:, kk) ! Check bounding box intersection - ! computeBBoxIntersection defined in Utilities.F90 of the utilities foldes + ! computeBBoxIntersection defined in utilities.F90 of the utilities foldes call computeBBoxIntersection(BBoxA, BBoxB, BBoxAB, overlap) if (overlap) then @@ -1752,7 +1752,7 @@ subroutine intersectionTreeSearch(jj, inpBBox, & BBoxB(4:6) = ADTree(kk)%xMax(4:6) ! Check bounding box intersection - ! computeBBoxIntersection defined in Utilities.F90 of the utilities foldes + ! computeBBoxIntersection defined in utilities.F90 of the utilities foldes call computeBBoxIntersection(BBoxA, BBoxB, BBoxAB, overlap) if (overlap) then diff --git a/src/ADT/adtProjections.F90 b/src/ADT/adtProjections.F90 index f14f3c4..c9fe472 100644 --- a/src/ADT/adtProjections.F90 +++ b/src/ADT/adtProjections.F90 @@ -756,7 +756,7 @@ subroutine dotProd(a, b, c) ! This subroutine simply computes a dot product c = a.dot.b ! This function is redundant with the one defined in - ! Utilities.F90, but I decided to do it in order to + ! utilities.F90, but I decided to do it in order to ! keep ADT independent of other pySurf modules. ! ! Ney Secco 2016-10 diff --git a/src/ADT/adtSearch.F90 b/src/ADT/adtSearch.F90 index 2ed3c06..a5f8d05 100644 --- a/src/ADT/adtSearch.F90 +++ b/src/ADT/adtSearch.F90 @@ -2493,10 +2493,9 @@ subroutine search(nCoor, coor, procID, & ! Complete the nonblocking sends of the interpolated data. - nProcRecvCur = 2 * nProcRecvCur do i = 1, nProcRecvCur - call mpi_waitany(nProcRecvCur, sendRecvRequest, sizeMessage, & - status, ierr) + call mpi_waitany(nProcRecvCur, sendRecvRequest(1, :), sizeMessage, status, ierr) + call mpi_waitany(nProcRecvCur, sendRecvRequest(2, :), sizeMessage, status, ierr) end do ! Release the memory of the buffers used in the nonblocking diff --git a/src/CGNSInterface/cgnsAPI.F90 b/src/CGNSInterface/cgnsAPI.F90 index 1f395da..0a79ed3 100644 --- a/src/CGNSInterface/cgnsAPI.F90 +++ b/src/CGNSInterface/cgnsAPI.F90 @@ -7,7 +7,7 @@ module CGNSapi real(kind=realType), dimension(:, :), allocatable, save :: coor integer(kind=intType), dimension(:, :), allocatable, save :: triaConn, quadsConn, barsConn integer(kind=intType), dimension(:), allocatable, save :: surfTriaPtr, surfQuadsPtr, curveBarsPtr - character*32, dimension(:), allocatable, save :: surfNames, curveNames + character(len=32), dimension(:), allocatable, save :: surfNames, curveNames ! coor: real(3,numNodes) -> X,Y,Z coordinates of all nodes ! triaConn: real(3,numTria) -> Triangles connectivity @@ -143,8 +143,8 @@ subroutine retrieveData(numCoor, numTriaConn, numQuadsConn, numBarsConn, & integer(kind=intType), intent(out), dimension(numSurfTriaPtr) :: surfTriaPtrData integer(kind=intType), intent(out), dimension(numSurfQuadsPtr) :: surfQuadsPtrData integer(kind=intType), intent(out), dimension(numCurveBarsPtr) :: curveBarsPtrData - character*32, intent(out), dimension(numSurfNames) :: surfNamesData - character*32, intent(out), dimension(numCurveNames) :: curveNamesData + character(len=32), intent(out), dimension(numSurfNames) :: surfNamesData + character(len=32), intent(out), dimension(numCurveNames) :: curveNamesData ! EXECUTION diff --git a/src/CGNSInterface/cgnsInterface.F90 b/src/CGNSInterface/cgnsInterface.F90 index cba85b2..b33e16a 100644 --- a/src/CGNSInterface/cgnsInterface.F90 +++ b/src/CGNSInterface/cgnsInterface.F90 @@ -34,7 +34,7 @@ subroutine readCGNSmain(cgns_file, comm, coor, triaConn, quadsConn, barsConn, & real(kind=realType), intent(out), dimension(:, :), allocatable :: coor integer(kind=intType), intent(out), dimension(:, :), allocatable :: triaConn, quadsConn, barsConn integer(kind=intType), intent(out), dimension(:), allocatable :: surfTriaPtr, surfQuadsPtr, curveBarsPtr - character*32, intent(out), dimension(:), allocatable :: surfNames, curveNames + character(len=32), intent(out), dimension(:), allocatable :: surfNames, curveNames ! Working integer(kind=intType) :: cg, ierr, i, myid @@ -46,7 +46,7 @@ subroutine readCGNSmain(cgns_file, comm, coor, triaConn, quadsConn, barsConn, & integer(kind=intType) :: iSurf, iCurve integer(kind=intType) :: nSurfSectionsTot, nCurveSectionsTot - character*32 :: baseName, secName + character(len=32) :: baseName, secName print *, '======================' print *, cgns_file @@ -289,8 +289,8 @@ subroutine readUnstructuredCGNS(cg, allNodes) integer(kind=intType) :: ierr, base, dims(3), iZone integer(kind=intType) :: nNodes, nCells integer(kind=intType) :: tmpSym, nSymm - character*32 :: zoneName, bocoName, famName - character*32 :: secName + character(len=32) :: zoneName, bocoName, famName + character(len=32) :: secName integer(kind=intType) :: nbocos, boco integer(kind=intType) :: nVertices, nElements, nzones diff --git a/src/adjoint/Makefile b/src/adjoint/Makefile index 3bd0f8e..a69a7ce 100644 --- a/src/adjoint/Makefile +++ b/src/adjoint/Makefile @@ -12,10 +12,10 @@ FF90_OBJECTS_1 = adBuffer.o \ FF90_OBJECTS_2 = intersection_b.o \ intersection_d.o \ - adtprojections_b.o \ - adtprojections_d.o \ - curveutils_d.o \ - curveutils_b.o + adtProjections_b.o \ + adtProjections_d.o \ + curveUtils_d.o \ + curveUtils_b.o default: all diff --git a/src/adjoint/Makefile_tapenade b/src/adjoint/Makefile_tapenade index 3fe1301..b25f4da 100644 --- a/src/adjoint/Makefile_tapenade +++ b/src/adjoint/Makefile_tapenade @@ -1,8 +1,8 @@ INPUT_FILES = \ ../common/precision.F90 \ ../common/constants.F90 \ - ../intersections/Intersection.F90 \ - ../utilities/Utilities.F90 \ + ../intersections/intersection.F90 \ + ../utilities/utilities.F90 \ ../curveSearch/curveUtils.F90 \ ../ADT/adtProjections.F90 \ @@ -28,14 +28,13 @@ default: done # Generate forward mode - tapenade -d -head $(ROUTINES) $(INPUT_FILES_NODIR) + tapenade -d -tgtmodulename "_d" -head $(ROUTINES) $(INPUT_FILES_NODIR) # Generate backward mode - tapenade -b -head $(ROUTINES) $(INPUT_FILES_NODIR) + tapenade -b -adjmodulename "_b" -head $(ROUTINES) $(INPUT_FILES_NODIR) # Remove modules that are not useful, but were differentiated anyway rm precision_* - rm constants_* # Edit AD code to use original modules that should not be differentiated sed -i -e 's/PRECISION_D/PRECISION/' -e 's/CONSTANTS_D/CONSTANTS/' *_d.f90 diff --git a/src/adjoint/adBuffer.f b/src/adjoint/adBuffer.f index 3f1996c..9a304d0 100644 --- a/src/adjoint/adBuffer.f +++ b/src/adjoint/adBuffer.f @@ -1,58 +1,276 @@ -C$Id: adBuffer.f 5257 2014-07-17 12:45:15Z vmp $ - -c PISTES D'AMELIORATIONS: -c Attention aux IF qui peuvent couter cher. -c On pourrait aussi bufferiser les bits avec N entiers, -c (1 bit par entier), passer tout le paquet a C et laisser -c C faire les jongleries de bitsets. -c On pourrait aussi optimiser en -O3 les primitives de ADFirstAidKit -c Regarder l'assembleur (option -S (et -o toto.s)) -c Pourchasser les divisions! - - BLOCK DATA LOOKINGORNOT - LOGICAL looking - COMMON /lookingfbuf/looking - DATA looking/.FALSE./ +C ************************ integer*4 ************************ + BLOCK DATA INTEGERS4 + INTEGER*4 adi4buf(512) + INTEGER adi4ibuf + COMMON /adi4fbuf/adi4buf,adi4ibuf + DATA adi4ibuf/1/ + END + + SUBROUTINE PUSHINTEGER4(x) + INTEGER*4 x, adi4buf(512) + INTEGER adi4ibuf + COMMON /adi4fbuf/adi4buf,adi4ibuf + CALL addftraffic(4) + adi4buf(adi4ibuf) = x + IF (adi4ibuf.eq.512) THEN + CALL PUSHINTEGER4ARRAY(adi4buf, 512) + CALL addftraffic(-512*4) + adi4ibuf = 1 + ELSE + adi4ibuf = adi4ibuf+1 + ENDIF + END + + SUBROUTINE POPINTEGER4(x) + INTEGER*4 x, adi4buf(512) + INTEGER adi4ibuf + COMMON /adi4fbuf/adi4buf,adi4ibuf + IF (adi4ibuf.le.1) THEN + CALL POPINTEGER4ARRAY(adi4buf, 512) + adi4ibuf = 512 + ELSE + adi4ibuf = adi4ibuf-1 + ENDIF + x = adi4buf(adi4ibuf) + END + +C ************************ integer*8 ************************ + BLOCK DATA INTEGERS8 + INTEGER*8 adi8buf(512) + INTEGER adi8ibuf + COMMON /adi8fbuf/adi8buf,adi8ibuf + DATA adi8ibuf/1/ + END + + SUBROUTINE PUSHINTEGER8(x) + INTEGER*8 x, adi8buf(512) + INTEGER adi8ibuf + COMMON /adi8fbuf/adi8buf,adi8ibuf + CALL addftraffic(8) + adi8buf(adi8ibuf) = x + IF (adi8ibuf.eq.512) THEN + CALL PUSHINTEGER8ARRAY(adi8buf, 512) + CALL addftraffic(-8*512) + adi8ibuf = 1 + ELSE + adi8ibuf = adi8ibuf+1 + ENDIF + END + + SUBROUTINE POPINTEGER8(x) + INTEGER*8 x, adi8buf(512) + INTEGER adi8ibuf + COMMON /adi8fbuf/adi8buf,adi8ibuf + IF (adi8ibuf.le.1) THEN + CALL POPINTEGER8ARRAY(adi8buf, 512) + adi8ibuf = 512 + ELSE + adi8ibuf = adi8ibuf-1 + ENDIF + x = adi8buf(adi8ibuf) + END + +C ************************ real*4 ************************ + BLOCK DATA REALS4 + REAL*4 adr4buf(512) + INTEGER adr4ibuf + COMMON /adr4fbuf/adr4buf,adr4ibuf + DATA adr4ibuf/1/ + END + + SUBROUTINE PUSHREAL4(x) + REAL*4 x, adr4buf(512) + INTEGER adr4ibuf + COMMON /adr4fbuf/adr4buf,adr4ibuf + CALL addftraffic(4) + adr4buf(adr4ibuf) = x + IF (adr4ibuf.eq.512) THEN + CALL PUSHREAL4ARRAY(adr4buf, 512) + CALL addftraffic(-4*512) + adr4ibuf = 1 + ELSE + adr4ibuf = adr4ibuf+1 + ENDIF + END + + SUBROUTINE POPREAL4(x) + REAL*4 x, adr4buf(512) + INTEGER adr4ibuf + COMMON /adr4fbuf/adr4buf,adr4ibuf + IF (adr4ibuf.le.1) THEN + CALL POPREAL4ARRAY(adr4buf, 512) + adr4ibuf = 512 + ELSE + adr4ibuf = adr4ibuf-1 + ENDIF + x = adr4buf(adr4ibuf) + END + +C ************************ real*8 ************************ + BLOCK DATA REALS8 + REAL*8 adr8buf(512) + INTEGER adr8ibuf + COMMON /adr8fbuf/adr8buf,adr8ibuf + DATA adr8ibuf/1/ + END + + SUBROUTINE PUSHREAL8(x) + REAL*8 x, adr8buf(512) + INTEGER adr8ibuf + COMMON /adr8fbuf/adr8buf,adr8ibuf + CALL addftraffic(8) + adr8buf(adr8ibuf) = x + IF (adr8ibuf.eq.512) THEN + CALL PUSHREAL8ARRAY(adr8buf, 512) + CALL addftraffic(-8*512) + adr8ibuf = 1 + ELSE + adr8ibuf = adr8ibuf+1 + ENDIF + END + + SUBROUTINE POPREAL8(x) + REAL*8 x, adr8buf(512) + INTEGER adr8ibuf + COMMON /adr8fbuf/adr8buf,adr8ibuf + IF (adr8ibuf.le.1) THEN + CALL POPREAL8ARRAY(adr8buf, 512) + adr8ibuf = 512 + ELSE + adr8ibuf = adr8ibuf-1 + ENDIF + x = adr8buf(adr8ibuf) + END + +C ************************ complex*8 ************************ + BLOCK DATA COMPLEXS8 + COMPLEX*8 adc8buf(512) + INTEGER adc8ibuf + COMMON /adc8fbuf/adc8buf,adc8ibuf + DATA adc8ibuf/1/ + END + + SUBROUTINE PUSHCOMPLEX8(x) + COMPLEX*8 x, adc8buf(512) + INTEGER adc8ibuf + COMMON /adc8fbuf/adc8buf,adc8ibuf + CALL addftraffic(8) + adc8buf(adc8ibuf) = x + IF (adc8ibuf.eq.512) THEN + CALL PUSHCOMPLEX8ARRAY(adc8buf, 512) + CALL addftraffic(-8*512) + adc8ibuf = 1 + ELSE + adc8ibuf = adc8ibuf+1 + ENDIF + END + + SUBROUTINE POPCOMPLEX8(x) + COMPLEX*8 x, adc8buf(512) + INTEGER adc8ibuf + COMMON /adc8fbuf/adc8buf,adc8ibuf + IF (adc8ibuf.le.1) THEN + CALL POPCOMPLEX8ARRAY(adc8buf, 512) + adc8ibuf = 512 + ELSE + adc8ibuf = adc8ibuf-1 + ENDIF + x = adc8buf(adc8ibuf) + END + +C ************************ complex*16 ************************ + BLOCK DATA COMPLEXS16 + COMPLEX*16 adc16buf(512) + INTEGER adc16ibuf + COMMON /adc16fbuf/adc16buf,adc16ibuf + DATA adc16ibuf/1/ + END + + SUBROUTINE PUSHCOMPLEX16(x) + COMPLEX*16 x, adc16buf(512) + INTEGER adc16ibuf + COMMON /adc16fbuf/adc16buf,adc16ibuf + CALL addftraffic(16) + adc16buf(adc16ibuf) = x + IF (adc16ibuf.eq.512) THEN + CALL PUSHCOMPLEX16ARRAY(adc16buf, 512) + CALL addftraffic(-16*512) + adc16ibuf = 1 + ELSE + adc16ibuf = adc16ibuf+1 + ENDIF + END + + SUBROUTINE POPCOMPLEX16(x) + COMPLEX*16 x, adc16buf(512) + INTEGER adc16ibuf + COMMON /adc16fbuf/adc16buf,adc16ibuf + IF (adc16ibuf.le.1) THEN + CALL POPCOMPLEX16ARRAY(adc16buf, 512) + adc16ibuf = 512 + ELSE + adc16ibuf = adc16ibuf-1 + ENDIF + x = adc16buf(adc16ibuf) END -c======================== BITS ==========================: +C ************************ character ************************ + BLOCK DATA CHARACTERS + CHARACTER ads1buf(512) + INTEGER ads1ibuf + COMMON /ads1fbuf/ads1buf,ads1ibuf + DATA ads1ibuf/1/ + END + + SUBROUTINE PUSHCHARACTER(x) + CHARACTER x, ads1buf(512) + INTEGER ads1ibuf + COMMON /ads1fbuf/ads1buf,ads1ibuf + CALL addftraffic(1) + ads1buf(ads1ibuf) = x + IF (ads1ibuf.eq.512) THEN + CALL PUSHNARRAY(ads1buf, 512, 1) + CALL addftraffic(-512) + ads1ibuf = 1 + ELSE + ads1ibuf = ads1ibuf+1 + ENDIF + END + + SUBROUTINE POPCHARACTER(x) + CHARACTER x, ads1buf(512) + INTEGER ads1ibuf + COMMON /ads1fbuf/ads1buf,ads1ibuf + IF (ads1ibuf.le.1) THEN + CALL POPNARRAY(ads1buf, 512, 1) + ads1ibuf = 512 + ELSE + ads1ibuf = ads1ibuf-1 + ENDIF + x = ads1buf(ads1ibuf) + END + +C ******************* bit (hidden primitives) *************** BLOCK DATA BITS - INTEGER*4 adbitbuf, adbitlbuf - INTEGER adbitibuf, adbitilbuf - LOGICAL adbitinlbuf - COMMON /adbitfbuf/adbitbuf,adbitlbuf, - + adbitibuf,adbitilbuf,adbitinlbuf + INTEGER*4 adbitbuf + INTEGER adbitibuf + COMMON /adbitfbuf/adbitbuf, adbitibuf DATA adbitbuf/0/ - DATA adbitlbuf/0/ DATA adbitibuf/0/ - DATA adbitilbuf/-1/ - DATA adbitinlbuf/.FALSE./ END -c [0,31] are the bit indices we can use in an INTEGER - SUBROUTINE PUSHBIT(bit) LOGICAL bit - INTEGER*4 adbitbuf, adbitlbuf - INTEGER adbitibuf, adbitilbuf - LOGICAL adbitinlbuf - COMMON /adbitfbuf/adbitbuf,adbitlbuf, - + adbitibuf,adbitilbuf,adbitinlbuf - LOGICAL looking - COMMON /lookingfbuf/looking -c - IF (adbitilbuf.ne.-1) THEN - adbitilbuf = -1 - adbitinlbuf = .FALSE. - looking = .FALSE. - ENDIF + INTEGER*4 adbitbuf + INTEGER adbitibuf + COMMON /adbitfbuf/adbitbuf, adbitibuf IF (bit) THEN adbitbuf = IBSET(adbitbuf, adbitibuf) ELSE adbitbuf = IBCLR(adbitbuf, adbitibuf) ENDIF IF (adbitibuf.ge.31) THEN - CALL PUSHINTEGER4(adbitbuf) + CALL PUSHNARRAY(adbitbuf, 4, 1) adbitbuf = 0 adbitibuf = 0 ELSE @@ -60,48 +278,12 @@ SUBROUTINE PUSHBIT(bit) ENDIF END - LOGICAL FUNCTION LOOKBIT() - INTEGER*4 adbitbuf, adbitlbuf - INTEGER adbitibuf, adbitilbuf - LOGICAL adbitinlbuf - COMMON /adbitfbuf/adbitbuf,adbitlbuf, - + adbitibuf,adbitilbuf,adbitinlbuf - LOGICAL looking - COMMON /lookingfbuf/looking -c - IF (adbitilbuf.eq.-1) THEN - adbitilbuf=adbitibuf - adbitlbuf = adbitbuf - IF (.not.looking) THEN - CALL RESETADLOOKSTACK() - looking = .TRUE. - ENDIF - ENDIF - IF (adbitilbuf.le.0) THEN - CALL LOOKINTEGER4(adbitlbuf) - adbitilbuf = 31 - ELSE - adbitilbuf = adbitilbuf-1 - ENDIF - LOOKBIT = BTEST(adbitlbuf, adbitilbuf) - END - LOGICAL FUNCTION POPBIT() - INTEGER*4 adbitbuf, adbitlbuf - INTEGER adbitibuf, adbitilbuf - LOGICAL adbitinlbuf - COMMON /adbitfbuf/adbitbuf,adbitlbuf, - + adbitibuf,adbitilbuf,adbitinlbuf - LOGICAL looking - COMMON /lookingfbuf/looking -c - IF (adbitilbuf.ne.-1) THEN - adbitilbuf = -1 - adbitinlbuf = .FALSE. - looking = .FALSE. - ENDIF + INTEGER*4 adbitbuf + INTEGER adbitibuf + COMMON /adbitfbuf/adbitbuf, adbitibuf IF (adbitibuf.le.0) THEN - CALL POPINTEGER4(adbitbuf) + CALL POPNARRAY(adbitbuf, 4, 1) adbitibuf = 31 ELSE adbitibuf = adbitibuf-1 @@ -109,7 +291,18 @@ LOGICAL FUNCTION POPBIT() POPBIT = BTEST(adbitbuf, adbitibuf) END -c====================== CONTROL =========================: +C *************************** boolean ************************* + SUBROUTINE PUSHBOOLEAN(x) + LOGICAL x + CALL PUSHBIT(x) + END + + SUBROUTINE POPBOOLEAN(x) + LOGICAL x, POPBIT + x = POPBIT() + END + +C ************************* control *********************** SUBROUTINE PUSHCONTROL1B(cc) INTEGER cc @@ -126,16 +319,6 @@ SUBROUTINE POPCONTROL1B(cc) ENDIF END - SUBROUTINE LOOKCONTROL1B(cc) - INTEGER cc - LOGICAL LOOKBIT - IF (LOOKBIT()) THEN - cc = 1 - ELSE - cc = 0 - ENDIF - END - SUBROUTINE PUSHCONTROL2B(cc) INTEGER cc CALL PUSHBIT(BTEST(cc,0)) @@ -153,17 +336,6 @@ SUBROUTINE POPCONTROL2B(cc) IF (POPBIT()) cc = IBSET(cc,0) END - SUBROUTINE LOOKCONTROL2B(cc) - INTEGER cc - LOGICAL LOOKBIT - IF (LOOKBIT()) THEN - cc = 2 - ELSE - cc = 0 - ENDIF - IF (LOOKBIT()) cc = IBSET(cc,0) - END - SUBROUTINE PUSHCONTROL3B(cc) INTEGER cc CALL PUSHBIT(BTEST(cc,0)) @@ -183,18 +355,6 @@ SUBROUTINE POPCONTROL3B(cc) IF (POPBIT()) cc = IBSET(cc,0) END - SUBROUTINE LOOKCONTROL3B(cc) - INTEGER cc - LOGICAL LOOKBIT - IF (LOOKBIT()) THEN - cc = 4 - ELSE - cc = 0 - ENDIF - IF (LOOKBIT()) cc = IBSET(cc,1) - IF (LOOKBIT()) cc = IBSET(cc,0) - END - SUBROUTINE PUSHCONTROL4B(cc) INTEGER cc CALL PUSHBIT(BTEST(cc,0)) @@ -216,19 +376,6 @@ SUBROUTINE POPCONTROL4B(cc) IF (POPBIT()) cc = IBSET(cc,0) END - SUBROUTINE LOOKCONTROL4B(cc) - INTEGER cc - LOGICAL LOOKBIT - IF (LOOKBIT()) THEN - cc = 8 - ELSE - cc = 0 - ENDIF - IF (LOOKBIT()) cc = IBSET(cc,2) - IF (LOOKBIT()) cc = IBSET(cc,1) - IF (LOOKBIT()) cc = IBSET(cc,0) - END - SUBROUTINE PUSHCONTROL5B(cc) INTEGER cc CALL PUSHBIT(BTEST(cc,0)) @@ -252,21 +399,32 @@ SUBROUTINE POPCONTROL5B(cc) IF (POPBIT()) cc = IBSET(cc,0) END - SUBROUTINE LOOKCONTROL5B(cc) + SUBROUTINE PUSHCONTROL6B(cc) INTEGER cc - LOGICAL LOOKBIT - IF (LOOKBIT()) THEN - cc = 16 + CALL PUSHBIT(BTEST(cc,0)) + CALL PUSHBIT(BTEST(cc,1)) + CALL PUSHBIT(BTEST(cc,2)) + CALL PUSHBIT(BTEST(cc,3)) + CALL PUSHBIT(BTEST(cc,4)) + CALL PUSHBIT(BTEST(cc,5)) + END + + SUBROUTINE POPCONTROL6B(cc) + INTEGER cc + LOGICAL POPBIT + IF (POPBIT()) THEN + cc = 32 ELSE cc = 0 ENDIF - IF (LOOKBIT()) cc = IBSET(cc,3) - IF (LOOKBIT()) cc = IBSET(cc,2) - IF (LOOKBIT()) cc = IBSET(cc,1) - IF (LOOKBIT()) cc = IBSET(cc,0) + IF (POPBIT()) cc = IBSET(cc,4) + IF (POPBIT()) cc = IBSET(cc,3) + IF (POPBIT()) cc = IBSET(cc,2) + IF (POPBIT()) cc = IBSET(cc,1) + IF (POPBIT()) cc = IBSET(cc,0) END - SUBROUTINE PUSHCONTROL6B(cc) + SUBROUTINE PUSHCONTROL7B(cc) INTEGER cc CALL PUSHBIT(BTEST(cc,0)) CALL PUSHBIT(BTEST(cc,1)) @@ -274,16 +432,18 @@ SUBROUTINE PUSHCONTROL6B(cc) CALL PUSHBIT(BTEST(cc,3)) CALL PUSHBIT(BTEST(cc,4)) CALL PUSHBIT(BTEST(cc,5)) + CALL PUSHBIT(BTEST(cc,6)) END - SUBROUTINE POPCONTROL6B(cc) + SUBROUTINE POPCONTROL7B(cc) INTEGER cc LOGICAL POPBIT IF (POPBIT()) THEN - cc = 16 + cc = 64 ELSE cc = 0 ENDIF + IF (POPBIT()) cc = IBSET(cc,5) IF (POPBIT()) cc = IBSET(cc,4) IF (POPBIT()) cc = IBSET(cc,3) IF (POPBIT()) cc = IBSET(cc,2) @@ -291,23 +451,35 @@ SUBROUTINE POPCONTROL6B(cc) IF (POPBIT()) cc = IBSET(cc,0) END - SUBROUTINE LOOKCONTROL6B(cc) + SUBROUTINE PUSHCONTROL8B(cc) INTEGER cc - LOGICAL LOOKBIT - IF (LOOKBIT()) THEN - cc = 16 + CALL PUSHBIT(BTEST(cc,0)) + CALL PUSHBIT(BTEST(cc,1)) + CALL PUSHBIT(BTEST(cc,2)) + CALL PUSHBIT(BTEST(cc,3)) + CALL PUSHBIT(BTEST(cc,4)) + CALL PUSHBIT(BTEST(cc,5)) + CALL PUSHBIT(BTEST(cc,6)) + CALL PUSHBIT(BTEST(cc,7)) + END + + SUBROUTINE POPCONTROL8B(cc) + INTEGER cc + LOGICAL POPBIT + IF (POPBIT()) THEN + cc = 128 ELSE cc = 0 ENDIF - IF (LOOKBIT()) cc = IBSET(cc,4) - IF (LOOKBIT()) cc = IBSET(cc,3) - IF (LOOKBIT()) cc = IBSET(cc,2) - IF (LOOKBIT()) cc = IBSET(cc,1) - IF (LOOKBIT()) cc = IBSET(cc,0) + IF (POPBIT()) cc = IBSET(cc,6) + IF (POPBIT()) cc = IBSET(cc,5) + IF (POPBIT()) cc = IBSET(cc,4) + IF (POPBIT()) cc = IBSET(cc,3) + IF (POPBIT()) cc = IBSET(cc,2) + IF (POPBIT()) cc = IBSET(cc,1) + IF (POPBIT()) cc = IBSET(cc,0) END - - SUBROUTINE PUSHCONTROL9B(cc) INTEGER cc CALL PUSHBIT(BTEST(cc,0)) @@ -319,14 +491,13 @@ SUBROUTINE PUSHCONTROL9B(cc) CALL PUSHBIT(BTEST(cc,6)) CALL PUSHBIT(BTEST(cc,7)) CALL PUSHBIT(BTEST(cc,8)) - CALL PUSHBIT(BTEST(cc,9)) END SUBROUTINE POPCONTROL9B(cc) INTEGER cc LOGICAL POPBIT IF (POPBIT()) THEN - cc = 16 + cc = 256 ELSE cc = 0 ENDIF @@ -340,1602 +511,460 @@ SUBROUTINE POPCONTROL9B(cc) IF (POPBIT()) cc = IBSET(cc,0) END - SUBROUTINE LOOKCONTROL9B(cc) - INTEGER cc - LOGICAL LOOKBIT - IF (LOOKBIT()) THEN - cc = 16 - ELSE - cc = 0 - ENDIF - IF (LOOKBIT()) cc = IBSET(cc,7) - IF (LOOKBIT()) cc = IBSET(cc,6) - IF (LOOKBIT()) cc = IBSET(cc,5) - IF (LOOKBIT()) cc = IBSET(cc,4) - IF (LOOKBIT()) cc = IBSET(cc,3) - IF (LOOKBIT()) cc = IBSET(cc,2) - IF (LOOKBIT()) cc = IBSET(cc,1) - IF (LOOKBIT()) cc = IBSET(cc,0) - END - -c======================= BOOLEANS ========================= +C ************************* pointer ************************ +c Don't know how to write a PUSH/POPPOINTER() in Fortran +c Maybe one should always call the C version instead... - SUBROUTINE PUSHBOOLEAN(x) - LOGICAL x - CALL PUSHBIT(x) - END - - SUBROUTINE LOOKBOOLEAN(x) - LOGICAL x, LOOKBIT - x = LOOKBIT() - END - - SUBROUTINE POPBOOLEAN(x) - LOGICAL x, POPBIT - x = POPBIT() - END - -c===================== CHARACTERS =======================: - BLOCK DATA CHARACTERS - CHARACTER ads1buf(512), ads1lbuf(512) - INTEGER ads1ibuf,ads1ilbuf - LOGICAL ads1inlbuf - COMMON /ads1fbuf/ads1buf,ads1lbuf, - + ads1ibuf,ads1ilbuf,ads1inlbuf - DATA ads1ibuf/1/ - DATA ads1ilbuf/-1/ - DATA ads1inlbuf/.FALSE./ - END - - SUBROUTINE PUSHCHARACTER(x) - CHARACTER x, ads1buf(512), ads1lbuf(512) - INTEGER ads1ibuf,ads1ilbuf - LOGICAL ads1inlbuf - COMMON /ads1fbuf/ads1buf,ads1lbuf, - + ads1ibuf,ads1ilbuf,ads1inlbuf - LOGICAL looking - COMMON /lookingfbuf/looking -c - CALL addftraffic(1) - IF (ads1ilbuf.ne.-1) THEN - ads1ilbuf = -1 - ads1inlbuf = .FALSE. - looking = .FALSE. - ENDIF - IF (ads1ibuf.ge.512) THEN - ads1buf(512) = x - CALL PUSHCHARACTERARRAY(ads1buf, 512) - CALL addftraffic(-512) - ads1ibuf = 1 - ELSE - ads1buf(ads1ibuf) = x - ads1ibuf = ads1ibuf+1 - ENDIF - END - - SUBROUTINE LOOKCHARACTER(x) - CHARACTER x, ads1buf(512), ads1lbuf(512) - INTEGER ads1ibuf,ads1ilbuf - LOGICAL ads1inlbuf - COMMON /ads1fbuf/ads1buf,ads1lbuf, - + ads1ibuf,ads1ilbuf,ads1inlbuf - LOGICAL looking - COMMON /lookingfbuf/looking -c - IF (ads1ilbuf.eq.-1) THEN - ads1ilbuf=ads1ibuf - IF (.not.looking) THEN - CALL RESETADLOOKSTACK() - looking = .TRUE. - ENDIF - ENDIF - IF (ads1ilbuf.le.1) THEN - CALL LOOKCHARACTERARRAY(ads1lbuf, 512) - ads1inlbuf = .TRUE. - ads1ilbuf = 512 - x = ads1lbuf(512) - ELSE - ads1ilbuf = ads1ilbuf-1 - if (ads1inlbuf) THEN - x = ads1lbuf(ads1ilbuf) - ELSE - x = ads1buf(ads1ilbuf) - ENDIF - ENDIF - END - - SUBROUTINE POPCHARACTER(x) - CHARACTER x, ads1buf(512), ads1lbuf(512) - INTEGER ads1ibuf,ads1ilbuf - LOGICAL ads1inlbuf - COMMON /ads1fbuf/ads1buf,ads1lbuf, - + ads1ibuf,ads1ilbuf,ads1inlbuf - LOGICAL looking - COMMON /lookingfbuf/looking -c - IF (ads1ilbuf.ne.-1) THEN - ads1ilbuf = -1 - ads1inlbuf = .FALSE. - looking = .FALSE. - ENDIF - IF (ads1ibuf.le.1) THEN - CALL POPCHARACTERARRAY(ads1buf, 512) - ads1ibuf = 512 - x = ads1buf(512) - ELSE - ads1ibuf = ads1ibuf-1 - x = ads1buf(ads1ibuf) - ENDIF - END - -c======================= INTEGER*4 =========================: - BLOCK DATA INTEGERS4 - INTEGER*4 adi4buf(512), adi4lbuf(512) - INTEGER adi4ibuf,adi4ilbuf - LOGICAL adi4inlbuf - COMMON /adi4fbuf/adi4buf,adi4lbuf, - + adi4ibuf,adi4ilbuf,adi4inlbuf - DATA adi4ibuf/1/ - DATA adi4ilbuf/-1/ - DATA adi4inlbuf/.FALSE./ - END - - SUBROUTINE PUSHINTEGER4(x) - INTEGER*4 x, adi4buf(512), adi4lbuf(512) - INTEGER adi4ibuf,adi4ilbuf - LOGICAL adi4inlbuf - COMMON /adi4fbuf/adi4buf,adi4lbuf, - + adi4ibuf,adi4ilbuf,adi4inlbuf - LOGICAL looking - COMMON /lookingfbuf/looking -c - CALL addftraffic(4) - IF (adi4ilbuf.ne.-1) THEN - adi4ilbuf = -1 - adi4inlbuf = .FALSE. - looking = .FALSE. - ENDIF - IF (adi4ibuf.ge.512) THEN - adi4buf(512) = x - CALL PUSHINTEGER4ARRAY(adi4buf, 512) - CALL addftraffic(-2048) - adi4ibuf = 1 - ELSE - adi4buf(adi4ibuf) = x - adi4ibuf = adi4ibuf+1 - ENDIF - END - - SUBROUTINE LOOKINTEGER4(x) - INTEGER*4 x, adi4buf(512), adi4lbuf(512) - INTEGER adi4ibuf,adi4ilbuf - LOGICAL adi4inlbuf - COMMON /adi4fbuf/adi4buf,adi4lbuf, - + adi4ibuf,adi4ilbuf,adi4inlbuf - LOGICAL looking - COMMON /lookingfbuf/looking -c - IF (adi4ilbuf.eq.-1) THEN - adi4ilbuf=adi4ibuf - IF (.not.looking) THEN - CALL RESETADLOOKSTACK() - looking = .TRUE. - ENDIF - ENDIF - IF (adi4ilbuf.le.1) THEN - CALL LOOKINTEGER4ARRAY(adi4lbuf, 512) - adi4inlbuf = .TRUE. - adi4ilbuf = 512 - x = adi4lbuf(512) - ELSE - adi4ilbuf = adi4ilbuf-1 - if (adi4inlbuf) THEN - x = adi4lbuf(adi4ilbuf) - ELSE - x = adi4buf(adi4ilbuf) - ENDIF - ENDIF - END - - SUBROUTINE POPINTEGER4(x) - INTEGER*4 x, adi4buf(512), adi4lbuf(512) - INTEGER adi4ibuf,adi4ilbuf - LOGICAL adi4inlbuf - COMMON /adi4fbuf/adi4buf,adi4lbuf, - + adi4ibuf,adi4ilbuf,adi4inlbuf - LOGICAL looking - COMMON /lookingfbuf/looking -c - IF (adi4ilbuf.ne.-1) THEN - adi4ilbuf = -1 - adi4inlbuf = .FALSE. - looking = .FALSE. - ENDIF - IF (adi4ibuf.le.1) THEN - CALL POPINTEGER4ARRAY(adi4buf, 512) - adi4ibuf = 512 - x = adi4buf(512) - ELSE - adi4ibuf = adi4ibuf-1 - x = adi4buf(adi4ibuf) - ENDIF - END - -c======================= INTEGER*8 ========================= - BLOCK DATA INTEGERS8 - INTEGER*8 adi8buf(512), adi8lbuf(512) - INTEGER adi8ibuf,adi8ilbuf - LOGICAL adi8inlbuf - COMMON /adi8fbuf/adi8buf,adi8lbuf, - + adi8ibuf,adi8ilbuf,adi8inlbuf - DATA adi8ibuf/1/ - DATA adi8ilbuf/-1/ - DATA adi8inlbuf/.FALSE./ - END - - SUBROUTINE PUSHINTEGER8(x) - INTEGER*8 x, adi8buf(512), adi8lbuf(512) - INTEGER adi8ibuf,adi8ilbuf - LOGICAL adi8inlbuf - COMMON /adi8fbuf/adi8buf,adi8lbuf, - + adi8ibuf,adi8ilbuf,adi8inlbuf - LOGICAL looking - COMMON /lookingfbuf/looking -c - CALL addftraffic(8) - IF (adi8ilbuf.ne.-1) THEN - adi8ilbuf = -1 - adi8inlbuf = .FALSE. - looking = .FALSE. - ENDIF - IF (adi8ibuf.ge.512) THEN - adi8buf(512) = x - CALL PUSHINTEGER8ARRAY(adi8buf, 512) - CALL addftraffic(-4096) - adi8ibuf = 1 - ELSE - adi8buf(adi8ibuf) = x - adi8ibuf = adi8ibuf+1 - ENDIF - END - - SUBROUTINE LOOKINTEGER8(x) - INTEGER*8 x, adi8buf(512), adi8lbuf(512) - INTEGER adi8ibuf,adi8ilbuf - LOGICAL adi8inlbuf - COMMON /adi8fbuf/adi8buf,adi8lbuf, - + adi8ibuf,adi8ilbuf,adi8inlbuf - LOGICAL looking - COMMON /lookingfbuf/looking -c - IF (adi8ilbuf.eq.-1) THEN - adi8ilbuf=adi8ibuf - IF (.not.looking) THEN - CALL RESETADLOOKSTACK() - looking = .TRUE. - ENDIF - ENDIF - IF (adi8ilbuf.le.1) THEN - CALL LOOKINTEGER8ARRAY(adi8lbuf, 512) - adi8inlbuf = .TRUE. - adi8ilbuf = 512 - x = adi8lbuf(512) - ELSE - adi8ilbuf = adi8ilbuf-1 - if (adi8inlbuf) THEN - x = adi8lbuf(adi8ilbuf) - ELSE - x = adi8buf(adi8ilbuf) - ENDIF - ENDIF - END - - SUBROUTINE POPINTEGER8(x) - INTEGER*8 x, adi8buf(512), adi8lbuf(512) - INTEGER adi8ibuf,adi8ilbuf - LOGICAL adi8inlbuf - COMMON /adi8fbuf/adi8buf,adi8lbuf, - + adi8ibuf,adi8ilbuf,adi8inlbuf - LOGICAL looking - COMMON /lookingfbuf/looking -c - IF (adi8ilbuf.ne.-1) THEN - adi8ilbuf = -1 - adi8inlbuf = .FALSE. - looking = .FALSE. - ENDIF - IF (adi8ibuf.le.1) THEN - CALL POPINTEGER8ARRAY(adi8buf, 512) - adi8ibuf = 512 - x = adi8buf(512) - ELSE - adi8ibuf = adi8ibuf-1 - x = adi8buf(adi8ibuf) - ENDIF - END - -c======================= REAL*4 ========================= - BLOCK DATA REALS4 - REAL*4 adr4buf(512), adr4lbuf(512) - INTEGER adr4ibuf,adr4ilbuf - LOGICAL adr4inlbuf - COMMON /adr4fbuf/adr4buf,adr4lbuf, - + adr4ibuf,adr4ilbuf,adr4inlbuf - DATA adr4ibuf/1/ - DATA adr4ilbuf/-1/ - DATA adr4inlbuf/.FALSE./ - END - - SUBROUTINE PUSHREAL4(x) - REAL*4 x, adr4buf(512), adr4lbuf(512) - INTEGER adr4ibuf,adr4ilbuf - LOGICAL adr4inlbuf - COMMON /adr4fbuf/adr4buf,adr4lbuf, - + adr4ibuf,adr4ilbuf,adr4inlbuf - LOGICAL looking - COMMON /lookingfbuf/looking -c - CALL addftraffic(4) - IF (adr4ilbuf.ne.-1) THEN - adr4ilbuf = -1 - adr4inlbuf = .FALSE. - looking = .FALSE. - ENDIF - IF (adr4ibuf.ge.512) THEN - adr4buf(512) = x - CALL PUSHREAL4ARRAY(adr4buf, 512) - CALL addftraffic(-2048) - adr4ibuf = 1 - ELSE - adr4buf(adr4ibuf) = x - adr4ibuf = adr4ibuf+1 - ENDIF - END - - SUBROUTINE LOOKREAL4(x) - REAL*4 x, adr4buf(512), adr4lbuf(512) - INTEGER adr4ibuf,adr4ilbuf - LOGICAL adr4inlbuf - COMMON /adr4fbuf/adr4buf,adr4lbuf, - + adr4ibuf,adr4ilbuf,adr4inlbuf - LOGICAL looking - COMMON /lookingfbuf/looking -c - IF (adr4ilbuf.eq.-1) THEN - adr4ilbuf=adr4ibuf - IF (.not.looking) THEN - CALL RESETADLOOKSTACK() - looking = .TRUE. - ENDIF - ENDIF - IF (adr4ilbuf.le.1) THEN - CALL LOOKREAL4ARRAY(adr4lbuf, 512) - adr4inlbuf = .TRUE. - adr4ilbuf = 512 - x = adr4lbuf(512) - ELSE - adr4ilbuf = adr4ilbuf-1 - if (adr4inlbuf) THEN - x = adr4lbuf(adr4ilbuf) - ELSE - x = adr4buf(adr4ilbuf) - ENDIF - ENDIF - END - - SUBROUTINE POPREAL4(x) - REAL*4 x, adr4buf(512), adr4lbuf(512) - INTEGER adr4ibuf,adr4ilbuf - LOGICAL adr4inlbuf - COMMON /adr4fbuf/adr4buf,adr4lbuf, - + adr4ibuf,adr4ilbuf,adr4inlbuf - LOGICAL looking - COMMON /lookingfbuf/looking -c - IF (adr4ilbuf.ne.-1) THEN - adr4ilbuf = -1 - adr4inlbuf = .FALSE. - looking = .FALSE. - ENDIF - IF (adr4ibuf.le.1) THEN - CALL POPREAL4ARRAY(adr4buf, 512) - adr4ibuf = 512 - x = adr4buf(512) - ELSE - adr4ibuf = adr4ibuf-1 - x = adr4buf(adr4ibuf) - ENDIF - END - -c======================= REAL*8 ========================= - BLOCK DATA REALS8 - REAL*8 adr8buf(512), adr8lbuf(512) - INTEGER adr8ibuf,adr8ilbuf - LOGICAL adr8inlbuf - COMMON /adr8fbuf/adr8buf,adr8lbuf, - + adr8ibuf,adr8ilbuf,adr8inlbuf - DATA adr8ibuf/1/ - DATA adr8ilbuf/-1/ - DATA adr8inlbuf/.FALSE./ - END - - SUBROUTINE PUSHREAL8(x) - REAL*8 x, adr8buf(512), adr8lbuf(512) - INTEGER adr8ibuf,adr8ilbuf - LOGICAL adr8inlbuf - COMMON /adr8fbuf/adr8buf,adr8lbuf, - + adr8ibuf,adr8ilbuf,adr8inlbuf - LOGICAL looking - COMMON /lookingfbuf/looking -c - CALL addftraffic(8) - IF (adr8ilbuf.ne.-1) THEN - adr8ilbuf = -1 - adr8inlbuf = .FALSE. - looking = .FALSE. - ENDIF - IF (adr8ibuf.ge.512) THEN - adr8buf(512) = x - CALL PUSHREAL8ARRAY(adr8buf, 512) - CALL addftraffic(-4096) - adr8ibuf = 1 - ELSE - adr8buf(adr8ibuf) = x - adr8ibuf = adr8ibuf+1 - ENDIF - END - - SUBROUTINE LOOKREAL8(x) - REAL*8 x, adr8buf(512), adr8lbuf(512) - INTEGER adr8ibuf,adr8ilbuf - LOGICAL adr8inlbuf - COMMON /adr8fbuf/adr8buf,adr8lbuf, - + adr8ibuf,adr8ilbuf,adr8inlbuf - LOGICAL looking - COMMON /lookingfbuf/looking -c - IF (adr8ilbuf.eq.-1) THEN - adr8ilbuf=adr8ibuf - IF (.not.looking) THEN - CALL RESETADLOOKSTACK() - looking = .TRUE. - ENDIF - ENDIF - IF (adr8ilbuf.le.1) THEN - CALL LOOKREAL8ARRAY(adr8lbuf, 512) - adr8inlbuf = .TRUE. - adr8ilbuf = 512 - x = adr8lbuf(512) - ELSE - adr8ilbuf = adr8ilbuf-1 - if (adr8inlbuf) THEN - x = adr8lbuf(adr8ilbuf) - ELSE - x = adr8buf(adr8ilbuf) - ENDIF - ENDIF - END - - SUBROUTINE POPREAL8(x) - REAL*8 x, adr8buf(512), adr8lbuf(512) - INTEGER adr8ibuf,adr8ilbuf - LOGICAL adr8inlbuf - COMMON /adr8fbuf/adr8buf,adr8lbuf, - + adr8ibuf,adr8ilbuf,adr8inlbuf - LOGICAL looking - COMMON /lookingfbuf/looking -c - IF (adr8ilbuf.ne.-1) THEN - adr8ilbuf = -1 - adr8inlbuf = .FALSE. - looking = .FALSE. - ENDIF - IF (adr8ibuf.le.1) THEN - CALL POPREAL8ARRAY(adr8buf, 512) - adr8ibuf = 512 - x = adr8buf(512) - ELSE - adr8ibuf = adr8ibuf-1 - x = adr8buf(adr8ibuf) - ENDIF - END - -c======================= COMPLEX*8 ========================= - BLOCK DATA COMPLEXS8 - COMPLEX*8 adc8buf(512), adc8lbuf(512) - INTEGER adc8ibuf,adc8ilbuf - LOGICAL adc8inlbuf - COMMON /adc8fbuf/adc8buf,adc8lbuf, - + adc8ibuf,adc8ilbuf,adc8inlbuf - DATA adc8ibuf/1/ - DATA adc8ilbuf/-1/ - DATA adc8inlbuf/.FALSE./ - END - - SUBROUTINE PUSHCOMPLEX8(x) - COMPLEX*8 x, adc8buf(512), adc8lbuf(512) - INTEGER adc8ibuf,adc8ilbuf - LOGICAL adc8inlbuf - COMMON /adc8fbuf/adc8buf,adc8lbuf, - + adc8ibuf,adc8ilbuf,adc8inlbuf - LOGICAL looking - COMMON /lookingfbuf/looking -c - CALL addftraffic(8) - IF (adc8ilbuf.ne.-1) THEN - adc8ilbuf = -1 - adc8inlbuf = .FALSE. - looking = .FALSE. - ENDIF - IF (adc8ibuf.ge.512) THEN - adc8buf(512) = x - CALL PUSHCOMPLEX8ARRAY(adc8buf, 512) - CALL addftraffic(-4096) - adc8ibuf = 1 - ELSE - adc8buf(adc8ibuf) = x - adc8ibuf = adc8ibuf+1 - ENDIF - END - - SUBROUTINE LOOKCOMPLEX8(x) - COMPLEX*8 x, adc8buf(512), adc8lbuf(512) - INTEGER adc8ibuf,adc8ilbuf - LOGICAL adc8inlbuf - COMMON /adc8fbuf/adc8buf,adc8lbuf, - + adc8ibuf,adc8ilbuf,adc8inlbuf - LOGICAL looking - COMMON /lookingfbuf/looking -c - IF (adc8ilbuf.eq.-1) THEN - adc8ilbuf=adc8ibuf - IF (.not.looking) THEN - CALL RESETADLOOKSTACK() - looking = .TRUE. - ENDIF - ENDIF - IF (adc8ilbuf.le.1) THEN - CALL LOOKCOMPLEX8ARRAY(adc8lbuf, 512) - adc8inlbuf = .TRUE. - adc8ilbuf = 512 - x = adc8lbuf(512) - ELSE - adc8ilbuf = adc8ilbuf-1 - if (adc8inlbuf) THEN - x = adc8lbuf(adc8ilbuf) - ELSE - x = adc8buf(adc8ilbuf) - ENDIF - ENDIF - END - - SUBROUTINE POPCOMPLEX8(x) - COMPLEX*8 x, adc8buf(512), adc8lbuf(512) - INTEGER adc8ibuf,adc8ilbuf - LOGICAL adc8inlbuf - COMMON /adc8fbuf/adc8buf,adc8lbuf, - + adc8ibuf,adc8ilbuf,adc8inlbuf - LOGICAL looking - COMMON /lookingfbuf/looking -c - IF (adc8ilbuf.ne.-1) THEN - adc8ilbuf = -1 - adc8inlbuf = .FALSE. - looking = .FALSE. - ENDIF - IF (adc8ibuf.le.1) THEN - CALL POPCOMPLEX8ARRAY(adc8buf, 512) - adc8ibuf = 512 - x = adc8buf(512) - ELSE - adc8ibuf = adc8ibuf-1 - x = adc8buf(adc8ibuf) - ENDIF - END - -c======================= COMPLEX*16 ========================= - BLOCK DATA COMPLEXS16 - COMPLEX*16 adc16buf(512), adc16lbuf(512) - INTEGER adc16ibuf,adc16ilbuf - LOGICAL adc16inlbuf - COMMON /adc16fbuf/adc16buf,adc16lbuf, - + adc16ibuf,adc16ilbuf,adc16inlbuf - DATA adc16ibuf/1/ - DATA adc16ilbuf/-1/ - DATA adc16inlbuf/.FALSE./ - END - - SUBROUTINE PUSHCOMPLEX16(x) - COMPLEX*16 x, adc16buf(512), adc16lbuf(512) - INTEGER adc16ibuf,adc16ilbuf - LOGICAL adc16inlbuf - COMMON /adc16fbuf/adc16buf,adc16lbuf, - + adc16ibuf,adc16ilbuf,adc16inlbuf - LOGICAL looking - COMMON /lookingfbuf/looking -c - CALL addftraffic(16) - IF (adc16ilbuf.ne.-1) THEN - adc16ilbuf = -1 - adc16inlbuf = .FALSE. - looking = .FALSE. - ENDIF - IF (adc16ibuf.ge.512) THEN - adc16buf(512) = x - CALL PUSHCOMPLEX16ARRAY(adc16buf, 512) - CALL addftraffic(-8192) - adc16ibuf = 1 - ELSE - adc16buf(adc16ibuf) = x - adc16ibuf = adc16ibuf+1 - ENDIF - END - - SUBROUTINE LOOKCOMPLEX16(x) - COMPLEX*16 x, adc16buf(512), adc16lbuf(512) - INTEGER adc16ibuf,adc16ilbuf - LOGICAL adc16inlbuf - COMMON /adc16fbuf/adc16buf,adc16lbuf, - + adc16ibuf,adc16ilbuf,adc16inlbuf - LOGICAL looking - COMMON /lookingfbuf/looking +C ********************************************************* +C HOW TO CREATE PUSH* POP* SUBROUTINES +C YET FOR OTHER DATA TYPES +C Duplicate and uncomment the commented code below. +C In the duplicated and uncommented code, replace: +C tttt -> BASIC TAPENADE TYPE NAME +C (in character, boolean, integer, real, complex, pointer,...) +C z7 -> LETTERSIZE FOR TYPE +C (LETTER in s, b, i, r, c, p, ...) (SIZE is type size in bytes) +C 7 -> TYPE SIZE IN BYTES +C *********************************************************/ + +C ************************* TTTT*7 ************************ +c BLOCK DATA TTTTS7 +c TTTT*7 adz7buf(512) +c INTEGER adz7ibuf +c COMMON /adz7fbuf/adz7buf,adz7ibuf +c DATA adz7ibuf/1/ +c END c - IF (adc16ilbuf.eq.-1) THEN - adc16ilbuf=adc16ibuf - IF (.not.looking) THEN - CALL RESETADLOOKSTACK() - looking = .TRUE. - ENDIF - ENDIF - IF (adc16ilbuf.le.1) THEN - CALL LOOKCOMPLEX16ARRAY(adc16lbuf, 512) - adc16inlbuf = .TRUE. - adc16ilbuf = 512 - x = adc16lbuf(512) - ELSE - adc16ilbuf = adc16ilbuf-1 - if (adc16inlbuf) THEN - x = adc16lbuf(adc16ilbuf) - ELSE - x = adc16buf(adc16ilbuf) - ENDIF - ENDIF - END - - SUBROUTINE POPCOMPLEX16(x) - COMPLEX*16 x, adc16buf(512), adc16lbuf(512) - INTEGER adc16ibuf,adc16ilbuf - LOGICAL adc16inlbuf - COMMON /adc16fbuf/adc16buf,adc16lbuf, - + adc16ibuf,adc16ilbuf,adc16inlbuf - LOGICAL looking - COMMON /lookingfbuf/looking +c SUBROUTINE PUSHTTTT7(x) +c TTTT*7 x, adz7buf(512) +c INTEGER adz7ibuf +c COMMON /adz7fbuf/adz7buf,adz7ibuf +c CALL addftraffic(7) +c adz7buf(adz7ibuf) = x +c IF (adz7ibuf.eq.512) THEN +c CALL PUSHTTTT7ARRAY(adz7buf, 512) +c CALL addftraffic(-7*512) +c adz7ibuf = 1 +c ELSE +c adz7ibuf = adz7ibuf+1 +c ENDIF +c END c - IF (adc16ilbuf.ne.-1) THEN - adc16ilbuf = -1 - adc16inlbuf = .FALSE. - looking = .FALSE. - ENDIF - IF (adc16ibuf.le.1) THEN - CALL POPCOMPLEX16ARRAY(adc16buf, 512) - adc16ibuf = 512 - x = adc16buf(512) - ELSE - adc16ibuf = adc16ibuf-1 - x = adc16buf(adc16ibuf) - ENDIF - END - -C=========== MEASUREMENT OF PUSH/POP TRAFFIC ========== - - BLOCK DATA MEMTRAFFIC - INTEGER*8 mmftraffic,mmftrafficM - COMMON /mmcomtraffic/mmftraffic,mmftrafficM - DATA mmftraffic/0/ - DATA mmftrafficM/0/ +c SUBROUTINE POPTTTT7(x) +c TTTT*7 x, adz7buf(512) +c INTEGER adz7ibuf +c COMMON /adz7fbuf/adz7buf,adz7ibuf +c IF (adz7ibuf.le.1) THEN +c CALL POPTTTT7ARRAY(adz7buf, 512) +c adz7ibuf = 512 +c ELSE +c adz7ibuf = adz7ibuf-1 +c ENDIF +c x = adz7buf(adz7ibuf) +c END + +C *************** REPEATED ACCESS MECHANISM ********************* +C 5 nested repeat levels should be more than enough!! + BLOCK DATA BUFFERREPEAT + INTEGER nbbufrepeat + INTEGER indexi4repeats(5) + INTEGER indexi8repeats(5) + INTEGER indexr4repeats(5) + INTEGER indexr8repeats(5) + INTEGER indexc8repeats(5) + INTEGER indexc16repeats(5) + INTEGER indexs1repeats(5) + INTEGER indexbitrepeats(5) + INTEGER indexptrrepeats(5) + COMMON /allbufferrepeats/indexi4repeats, indexi8repeats, + + indexr4repeats, indexr8repeats, indexc8repeats, + + indexc16repeats, indexs1repeats, indexbitrepeats, + + indexptrrepeats, nbbufrepeat + DATA nbbufrepeat/0/ + END + + SUBROUTINE ADSTACK_STARTREPEAT() + INTEGER nbbufrepeat + INTEGER indexi4repeats(5) + INTEGER indexi8repeats(5) + INTEGER indexr4repeats(5) + INTEGER indexr8repeats(5) + INTEGER indexc8repeats(5) + INTEGER indexc16repeats(5) + INTEGER indexs1repeats(5) + INTEGER indexbitrepeats(5) + INTEGER indexptrrepeats(5) + COMMON /allbufferrepeats/indexi4repeats, indexi8repeats, + + indexr4repeats, indexr8repeats, indexc8repeats, + + indexc16repeats, indexs1repeats, indexbitrepeats, + + indexptrrepeats, nbbufrepeat + INTEGER*4 adi4buf(512) + INTEGER adi4ibuf + COMMON /adi4fbuf/adi4buf,adi4ibuf + INTEGER*8 adi8buf(512) + INTEGER adi8ibuf + COMMON /adi8fbuf/adi8buf,adi8ibuf + REAL*4 adr4buf(512) + INTEGER adr4ibuf + COMMON /adr4fbuf/adr4buf,adr4ibuf + REAL*8 adr8buf(512) + INTEGER adr8ibuf + COMMON /adr8fbuf/adr8buf,adr8ibuf + COMPLEX*8 adc8buf(512) + INTEGER adc8ibuf + COMMON /adc8fbuf/adc8buf,adc8ibuf + COMPLEX*16 adc16buf(512) + INTEGER adc16ibuf + COMMON /adc16fbuf/adc16buf,adc16ibuf + CHARACTER ads1buf(512) + INTEGER ads1ibuf + COMMON /ads1fbuf/ads1buf,ads1ibuf + INTEGER*4 adbitbuf + INTEGER adbitibuf + COMMON /adbitfbuf/adbitbuf, adbitibuf +c Create a new "buffers" repeat level: + nbbufrepeat = nbbufrepeat+1 +c Also create a new repeat level for the main stack: + CALL STARTSTACKREPEAT1() +c Push all local buffers on the main stack. +c 3rd arg is 0 to deactivate the check for stack read-only zone: + if (adi4ibuf.gt.1) CALL PUSHNARRAY(adi4buf, 4*(adi4ibuf-1), 0) + if (adi8ibuf.gt.1) CALL PUSHNARRAY(adi8buf, 8*(adi8ibuf-1), 0) + if (adr4ibuf.gt.1) CALL PUSHNARRAY(adr4buf, 4*(adr4ibuf-1), 0) + if (adr8ibuf.gt.1) CALL PUSHNARRAY(adr8buf, 8*(adr8ibuf-1), 0) + if (adc8ibuf.gt.1) CALL PUSHNARRAY(adc8buf, 8*(adc8ibuf-1), 0) + if (adc16ibuf.gt.1)CALL PUSHNARRAY(adc16buf,16*(adc16ibuf-1),0) + if (ads1ibuf.gt.1) CALL PUSHNARRAY(ads1buf, ads1ibuf-1, 0) + CALL PUSHNARRAY(adbitbuf, 4, 0) +c if (adptribuf.gt.1) CALL PUSHNARRAY(adptrbuf, 8*(adptribuf-1), 0) + indexi4repeats(nbbufrepeat) = adi4ibuf + indexi8repeats(nbbufrepeat) = adi8ibuf + indexr4repeats(nbbufrepeat) = adr4ibuf + indexr8repeats(nbbufrepeat) = adr8ibuf + indexc8repeats(nbbufrepeat) = adc8ibuf + indexc16repeats(nbbufrepeat) = adc16ibuf + indexs1repeats(nbbufrepeat) = ads1ibuf + indexbitrepeats(nbbufrepeat) = adbitibuf +c indexptrrepeats(nbbufrepeat) = adptribuf +c Store current location as repeat location of new repeat level. +c Note that this repeat location protects below as read-only. +c Make the new repeat level the current repeat level for the main stack: + CALL STARTSTACKREPEAT2() + END + +c Note: ADSTACK_RESETREPEAT() forces exit from any internal checkpointed sequence, +c i.e. all nested push'es are forced popped. + SUBROUTINE ADSTACK_RESETREPEAT() + INTEGER nbbufrepeat + INTEGER indexi4repeats(5) + INTEGER indexi8repeats(5) + INTEGER indexr4repeats(5) + INTEGER indexr8repeats(5) + INTEGER indexc8repeats(5) + INTEGER indexc16repeats(5) + INTEGER indexs1repeats(5) + INTEGER indexbitrepeats(5) + INTEGER indexptrrepeats(5) + COMMON /allbufferrepeats/indexi4repeats, indexi8repeats, + + indexr4repeats, indexr8repeats, indexc8repeats, + + indexc16repeats, indexs1repeats, indexbitrepeats, + + indexptrrepeats, nbbufrepeat + INTEGER*4 adi4buf(512) + INTEGER adi4ibuf + COMMON /adi4fbuf/adi4buf,adi4ibuf + INTEGER*8 adi8buf(512) + INTEGER adi8ibuf + COMMON /adi8fbuf/adi8buf,adi8ibuf + REAL*4 adr4buf(512) + INTEGER adr4ibuf + COMMON /adr4fbuf/adr4buf,adr4ibuf + REAL*8 adr8buf(512) + INTEGER adr8ibuf + COMMON /adr8fbuf/adr8buf,adr8ibuf + COMPLEX*8 adc8buf(512) + INTEGER adc8ibuf + COMMON /adc8fbuf/adc8buf,adc8ibuf + COMPLEX*16 adc16buf(512) + INTEGER adc16ibuf + COMMON /adc16fbuf/adc16buf,adc16ibuf + CHARACTER ads1buf(512) + INTEGER ads1ibuf + COMMON /ads1fbuf/ads1buf,ads1ibuf + INTEGER*4 adbitbuf + INTEGER adbitibuf + COMMON /adbitfbuf/adbitbuf, adbitibuf +c First stage of reset repeat for the main stack: + CALL RESETSTACKREPEAT1() +c Restore all local buffers: + adi4ibuf = indexi4repeats(nbbufrepeat) + adi8ibuf = indexi8repeats(nbbufrepeat) + adr4ibuf = indexr4repeats(nbbufrepeat) + adr8ibuf = indexr8repeats(nbbufrepeat) + adc8ibuf = indexc8repeats(nbbufrepeat) + adc16ibuf = indexc16repeats(nbbufrepeat) + ads1ibuf = indexs1repeats(nbbufrepeat) + adbitibuf = indexbitrepeats(nbbufrepeat) +c adptribuf = indexptrrepeats(nbbufrepeat) +c if (adptribuf.gt.1) CALL POPNARRAY(adptrbuf, 8*(adptribuf-1),0) + CALL POPNARRAY(adbitbuf, 4, 0) +c 3rd arg is 0 to deactivate the check for stack read-only zone: + if (ads1ibuf.gt.1) CALL POPNARRAY(ads1buf, ads1ibuf-1, 0) + if (adc16ibuf.gt.1)CALL POPNARRAY(adc16buf,16*(adc16ibuf-1),0) + if (adc8ibuf.gt.1) CALL POPNARRAY(adc8buf, 8*(adc8ibuf-1), 0) + if (adr8ibuf.gt.1) CALL POPNARRAY(adr8buf, 8*(adr8ibuf-1), 0) + if (adr4ibuf.gt.1) CALL POPNARRAY(adr4buf, 4*(adr4ibuf-1), 0) + if (adi8ibuf.gt.1) CALL POPNARRAY(adi8buf, 8*(adi8ibuf-1), 0) + if (adi4ibuf.gt.1) CALL POPNARRAY(adi4buf, 4*(adi4ibuf-1), 0) +c Second stage of reset repeat for the main stack: + CALL RESETSTACKREPEAT2() + END + +c Note: ADSTACK_ENDREPEAT() forces exit from any internal checkpointed sequence, +c i.e. all nested push'es are forced popped. + SUBROUTINE ADSTACK_ENDREPEAT() + INTEGER nbbufrepeat + INTEGER indexi4repeats(5) + INTEGER indexi8repeats(5) + INTEGER indexr4repeats(5) + INTEGER indexr8repeats(5) + INTEGER indexc8repeats(5) + INTEGER indexc16repeats(5) + INTEGER indexs1repeats(5) + INTEGER indexbitrepeats(5) + INTEGER indexptrrepeats(5) + COMMON /allbufferrepeats/indexi4repeats, indexi8repeats, + + indexr4repeats, indexr8repeats, indexc8repeats, + + indexc16repeats, indexs1repeats, indexbitrepeats, + + indexptrrepeats, nbbufrepeat +c End repeat for the main stack: + CALL ENDSTACKREPEAT() ; +c Remove top repeat level: + nbbufrepeat = nbbufrepeat-1 + END + + SUBROUTINE SHOWI4BUFFERANDREPEATS(xbuf,xibuf, + + xrepeats,nbbufrepeat) + INTEGER*4 xbuf(512) + INTEGER xibuf, xrepeats(5), nbbufrepeat + CHARACTER(len=3) seps(513) + INTEGER i + DO i=1,513 + seps(i) = '' + ENDDO + seps(xibuf) = ' |' + WRITE (6,991) (seps(i),xbuf(i),i=1,512), + + (xrepeats(i),i=1,nbbufrepeat) + 991 FORMAT(' I4:',512(a2,i10.1),' REPEATS:',5i3) + END + + SUBROUTINE SHOWI8BUFFERANDREPEATS(xbuf,xibuf, + + xrepeats,nbbufrepeat) + INTEGER*8 xbuf(512) + INTEGER xibuf, xrepeats(5), nbbufrepeat + CHARACTER(len=3) seps(513) + INTEGER i + DO i=1,513 + seps(i) = '' + ENDDO + seps(xibuf) = ' |' + WRITE (6,991) (seps(i),xbuf(i),i=1,512), + + (xrepeats(i),i=1,nbbufrepeat) + 991 FORMAT(' I8:',512(a2,i20.1),' REPEATS:',5i3) + END + + SUBROUTINE SHOWR4BUFFERANDREPEATS(xbuf,xibuf, + + xrepeats,nbbufrepeat) + REAL*4 xbuf(512) + INTEGER xibuf, xrepeats(5), nbbufrepeat + CHARACTER(len=3) seps(513) + INTEGER i + DO i=1,513 + seps(i) = '' + ENDDO + seps(xibuf) = ' |' + WRITE (6,991) (seps(i),xbuf(i),i=1,512), + + (xrepeats(i),i=1,nbbufrepeat) + 991 FORMAT(' R4:',512(a2,e12.5),' REPEATS:',5i3) + END + + SUBROUTINE SHOWR8BUFFERANDREPEATS(xbuf,xibuf, + + xrepeats,nbbufrepeat) + REAL*8 xbuf(512) + INTEGER xibuf, xrepeats(5), nbbufrepeat + CHARACTER(len=3) seps(513) + INTEGER i + DO i=1,513 + seps(i) = '' + ENDDO + seps(xibuf) = ' |' + WRITE (6,991) (seps(i),xbuf(i),i=1,512), + + (xrepeats(i),i=1,nbbufrepeat) + 991 FORMAT(' R8:',512(a2,d12.5),' REPEATS:',5i3) + END + + SUBROUTINE SHOWC8BUFFERANDREPEATS(xbuf,xibuf, + + xrepeats,nbbufrepeat) + COMPLEX*8 xbuf(512) + INTEGER xibuf, xrepeats(5), nbbufrepeat + CHARACTER(len=3) seps(513) + INTEGER i + DO i=1,513 + seps(i) = '' + ENDDO + seps(xibuf) = ' |' + WRITE (6,991) (seps(i),xbuf(i),i=1,512), + + (xrepeats(i),i=1,nbbufrepeat) + 991 FORMAT(' C8:',512(a2,'(',e12.5,' i',e12.5,')'), + + ' REPEATS:',5i3) + END + + SUBROUTINE SHOWC16BUFFERANDREPEATS(xbuf,xibuf, + + xrepeats,nbbufrepeat) + COMPLEX*16 xbuf(512) + INTEGER xibuf, xrepeats(5), nbbufrepeat + CHARACTER(len=3) seps(513) + INTEGER i + DO i=1,513 + seps(i) = '' + ENDDO + seps(xibuf) = ' |' + WRITE (6,991) (seps(i),xbuf(i),i=1,512), + + (xrepeats(i),i=1,nbbufrepeat) + 991 FORMAT(' C16:',512(a2,'(',d12.5,' i',d12.5,')'), + + ' REPEATS:',5i3) + END + + SUBROUTINE SHOWS1BUFFERANDREPEATS(xbuf,xibuf, + + xrepeats,nbbufrepeat) + CHARACTER xbuf(512) + INTEGER xibuf, xrepeats(5), nbbufrepeat + CHARACTER(len=3) seps(513) + INTEGER i + DO i=1,513 + seps(i) = '' + ENDDO + seps(xibuf) = ' |' + WRITE (6,991) (seps(i),xbuf(i),i=1,512), + + (xrepeats(i),i=1,nbbufrepeat) + 991 FORMAT(' STR:',512(a2,a1), + + ' REPEATS:',5i3) + END + + SUBROUTINE SHOWBITBUFFERANDREPEATS(xbuf,xibuf, + + xrepeats,nbbufrepeat) + INTEGER*4 xbuf + INTEGER xibuf, xrepeats(5), nbbufrepeat,i + WRITE (6,991) xibuf,xbuf,(xrepeats(i),i=1,nbbufrepeat) + 991 FORMAT(' BITS:',i2,' in ',z8,' REPEATS:',5i3) + END + + SUBROUTINE SHOWSTACKANDBUFFERS(locationName) + CHARACTER(*) locationName + INTEGER nbbufrepeat + INTEGER indexi4repeats(5) + INTEGER indexi8repeats(5) + INTEGER indexr4repeats(5) + INTEGER indexr8repeats(5) + INTEGER indexc8repeats(5) + INTEGER indexc16repeats(5) + INTEGER indexs1repeats(5) + INTEGER indexbitrepeats(5) + INTEGER indexptrrepeats(5) + COMMON /allbufferrepeats/indexi4repeats, indexi8repeats, + + indexr4repeats, indexr8repeats, indexc8repeats, + + indexc16repeats, indexs1repeats, indexbitrepeats, + + indexptrrepeats, nbbufrepeat + INTEGER*4 adi4buf(512) + INTEGER adi4ibuf + COMMON /adi4fbuf/adi4buf,adi4ibuf + INTEGER*8 adi8buf(512) + INTEGER adi8ibuf + COMMON /adi8fbuf/adi8buf,adi8ibuf + REAL*4 adr4buf(512) + INTEGER adr4ibuf + COMMON /adr4fbuf/adr4buf,adr4ibuf + REAL*8 adr8buf(512) + INTEGER adr8ibuf + COMMON /adr8fbuf/adr8buf,adr8ibuf + COMPLEX*8 adc8buf(512) + INTEGER adc8ibuf + COMMON /adc8fbuf/adc8buf,adc8ibuf + COMPLEX*16 adc16buf(512) + INTEGER adc16ibuf + COMMON /adc16fbuf/adc16buf,adc16ibuf + CHARACTER ads1buf(512) + INTEGER ads1ibuf + COMMON /ads1fbuf/ads1buf,ads1ibuf + INTEGER*4 adbitbuf + INTEGER adbitibuf + COMMON /adbitfbuf/adbitbuf, adbitibuf + print *,locationName + CALL SHOWSTACK() + CALL SHOWI4BUFFERANDREPEATS(adi4buf,adi4ibuf, + + indexi4repeats,nbbufrepeat) + CALL SHOWI8BUFFERANDREPEATS(adi8buf,adi8ibuf, + + indexi8repeats,nbbufrepeat) + CALL SHOWR4BUFFERANDREPEATS(adr4buf,adr4ibuf, + + indexr4repeats,nbbufrepeat) + CALL SHOWR8BUFFERANDREPEATS(adr8buf,adr8ibuf, + + indexr8repeats,nbbufrepeat) + CALL SHOWC8BUFFERANDREPEATS(adc8buf,adc8ibuf, + + indexc8repeats,nbbufrepeat) + CALL SHOWC16BUFFERANDREPEATS(adc16buf,adc16ibuf, + + indexc16repeats,nbbufrepeat) + CALL SHOWS1BUFFERANDREPEATS(ads1buf,ads1ibuf, + + indexs1repeats,nbbufrepeat) + CALL SHOWBITBUFFERANDREPEATS(adbitbuf,adbitibuf, + + indexbitrepeats,nbbufrepeat) +c No pointer buffer so far... + END + + SUBROUTINE SHOWSTACKANDBUFFERSSIZE() + INTEGER*4 adi4buf(512) + INTEGER adi4ibuf + COMMON /adi4fbuf/adi4buf,adi4ibuf + INTEGER*8 adi8buf(512) + INTEGER adi8ibuf + COMMON /adi8fbuf/adi8buf,adi8ibuf + REAL*4 adr4buf(512) + INTEGER adr4ibuf + COMMON /adr4fbuf/adr4buf,adr4ibuf + REAL*8 adr8buf(512) + INTEGER adr8ibuf + COMMON /adr8fbuf/adr8buf,adr8ibuf + COMPLEX*8 adc8buf(512) + INTEGER adc8ibuf + COMMON /adc8fbuf/adc8buf,adc8ibuf + COMPLEX*16 adc16buf(512) + INTEGER adc16ibuf + COMMON /adc16fbuf/adc16buf,adc16ibuf + CHARACTER ads1buf(512) + INTEGER ads1ibuf + COMMON /ads1fbuf/ads1buf,ads1ibuf + INTEGER*4 adbitbuf + INTEGER adbitibuf + COMMON /adbitfbuf/adbitbuf, adbitibuf + CALL SHOWSTACKSIZE(adi4ibuf-1,adi8ibuf-1,adr4ibuf-1,adr8ibuf-1, + + adc8ibuf-1,adc16ibuf-1,ads1ibuf-1,adbitibuf-1,0) + END + +C=========== MEASUREMENT OF PUSH TRAFFIC ========== + + BLOCK DATA BUFTRAFFICBLOCK + INTEGER*8 buffertraffic + COMMON /BUFTRAFFIC/buffertraffic + DATA buffertraffic/0/ END subroutine addftraffic(n) INTEGER n - INTEGER*8 mmftraffic,mmftrafficM - COMMON /mmcomtraffic/mmftraffic,mmftrafficM -c - mmftraffic = mmftraffic+n - if (mmftraffic.ge.1000000) then - 100 mmftraffic = mmftraffic-1000000 - mmftrafficM = mmftrafficM+1 - if (mmftraffic.ge.1000000) then - goto 100 - else - goto 300 - endif - else if (mmftraffic.lt.0) then - 200 mmftraffic = mmftraffic+1000000 - mmftrafficM = mmftrafficM-1 - if (mmftraffic.lt.0) then - goto 200 - else - goto 300 - endif - endif - 300 continue - END - - SUBROUTINE PRINTTRAFFIC() - INTEGER*8 mmftraffic,mmftrafficM - COMMON /mmcomtraffic/mmftraffic,mmftrafficM - CALL printctraffic() - CALL printftrafficinc(mmftrafficM, 1000000, mmftraffic) - CALL printtotaltraffic(mmftrafficM, 1000000, mmftraffic) -c write (6,1001) ' F Traffic: ',mmftrafficM,' Mb and ', -c + (((mmftraffic*1000)/1024)*1000)/1024, ' millionths' -c 1001 format(a,i6,a,i6,a) + INTEGER*8 buffertraffic + COMMON /BUFTRAFFIC/buffertraffic + buffertraffic = buffertraffic+n END -C ============ PRINTING THE SIZE OF STACKS AND BUFFERS ========== - - SUBROUTINE PRINTBUFFERTOP() - integer*4 SMALLSTACKSIZE - integer*4 size - - size = SMALLSTACKSIZE() - print *,'Buffer size:',size,' bytes i.e. ',size/1024.0,' Kbytes' + SUBROUTINE ADSTACK_SHOWTRAFFIC() + INTEGER*8 buffertraffic + COMMON /BUFTRAFFIC/buffertraffic + call SHOWTOTALTRAFFIC(buffertraffic) END - - FUNCTION SMALLSTACKSIZE() - CHARACTER ads1buf(512), ads1lbuf(512) - INTEGER ads1ibuf,ads1ilbuf - LOGICAL ads1inlbuf - COMMON /ads1fbuf/ads1buf,ads1lbuf, - + ads1ibuf,ads1ilbuf,ads1inlbuf -c LOGICAL adl4buf(512), adl4lbuf(512) -c INTEGER adl4ibuf,adl4ilbuf -c LOGICAL adl4inlbuf -c COMMON /adl4fbuf/adl4buf,adl4lbuf, -c + adl4ibuf,adl4ilbuf,adl4inlbuf - INTEGER*4 adi4buf(512), adi4lbuf(512) - INTEGER adi4ibuf,adi4ilbuf - LOGICAL adi4inlbuf - COMMON /adi4fbuf/adi4buf,adi4lbuf, - + adi4ibuf,adi4ilbuf,adi4inlbuf - INTEGER*8 adi8buf(512), adi8lbuf(512) - INTEGER adi8ibuf,adi8ilbuf - LOGICAL adi8inlbuf - COMMON /adi8fbuf/adi8buf,adi8lbuf, - + adi8ibuf,adi8ilbuf,adi8inlbuf -c INTEGER*16 adi16buf(512), adi16lbuf(512) -c INTEGER adi16ibuf,adi16ilbuf -c LOGICAL adi16inlbuf -c COMMON /adi16fbuf/adi16buf,adi16lbuf, -c + adi16ibuf,adi16ilbuf,adi16inlbuf - REAL*4 adr4buf(512), adr4lbuf(512) - INTEGER adr4ibuf,adr4ilbuf - LOGICAL adr4inlbuf - COMMON /adr4fbuf/adr4buf,adr4lbuf, - + adr4ibuf,adr4ilbuf,adr4inlbuf - REAL*8 adr8buf(512), adr8lbuf(512) - INTEGER adr8ibuf,adr8ilbuf - LOGICAL adr8inlbuf - COMMON /adr8fbuf/adr8buf,adr8lbuf, - + adr8ibuf,adr8ilbuf,adr8inlbuf -c REAL*16 adr16buf(512), adr16lbuf(512) -c INTEGER adr16ibuf,adr16ilbuf -c LOGICAL adr16inlbuf -c COMMON /adr16fbuf/adr16buf,adr16lbuf, -c + adr16ibuf,adr16ilbuf,adr16inlbuf -c REAL*32 x, adr32buf(512), adr32lbuf(512) -c INTEGER adr32ibuf,adr32ilbuf -c LOGICAL adr32inlbuf -c COMMON /adr32fbuf/adr32buf,adr32lbuf, -c + adr32ibuf,adr32ilbuf,adr32inlbuf -c COMPLEX*4 adc4buf(512), adc4lbuf(512) -c INTEGER adc4ibuf,adc4ilbuf -c LOGICAL adc4inlbuf -c COMMON /adc4fbuf/adc4buf,adc4lbuf, -c + adc4ibuf,adc4ilbuf,adc4inlbuf - COMPLEX*8 adc8buf(512), adc8lbuf(512) - INTEGER adc8ibuf,adc8ilbuf - LOGICAL adc8inlbuf - COMMON /adc8fbuf/adc8buf,adc8lbuf, - + adc8ibuf,adc8ilbuf,adc8inlbuf - COMPLEX*16 adc16buf(512), adc16lbuf(512) - INTEGER adc16ibuf,adc16ilbuf - LOGICAL adc16inlbuf - COMMON /adc16fbuf/adc16buf,adc16lbuf, - + adc16ibuf,adc16ilbuf,adc16inlbuf -c COMPLEX*32 adc32buf(512), adc32lbuf(512) -c INTEGER adc32ibuf,adc32ilbuf -c LOGICAL adc32inlbuf -c COMMON /adc32fbuf/adc32buf,adc32lbuf, -c + adc32ibuf,adc32ilbuf,adc32inlbuf - integer*4 smallstacksize -c - smallstacksize = 0 - smallstacksize = smallstacksize + (ads1ibuf-1)*1 -c smallstacksize = smallstacksize + (adl4ibuf-1)*4 - smallstacksize = smallstacksize + (adi4ibuf-1)*4 - smallstacksize = smallstacksize + (adi8ibuf-1)*8 -c smallstacksize = smallstacksize + (adi16ibuf-1)*16 - smallstacksize = smallstacksize + (adr4ibuf-1)*4 - smallstacksize = smallstacksize + (adr8ibuf-1)*8 -c smallstacksize = smallstacksize + (adr16ibuf-1)*16 -c smallstacksize = smallstacksize + (adr32ibuf-1)*32 -c smallstacksize = smallstacksize + (adc4ibuf-1)*4 - smallstacksize = smallstacksize + (adc8ibuf-1)*8 - smallstacksize = smallstacksize + (adc16ibuf-1)*16 -c smallstacksize = smallstacksize + (adc32ibuf-1)*32 -c - end - -c Very complete display of the current size of the -c push/look/pop local Fortran stacks and global C stack. - SUBROUTINE PRINTALLBUFFERS() - CHARACTER ads1buf(512), ads1lbuf(512) - INTEGER ads1ibuf,ads1ilbuf - LOGICAL ads1inlbuf - COMMON /ads1fbuf/ads1buf,ads1lbuf, - + ads1ibuf,ads1ilbuf,ads1inlbuf -c LOGICAL adl4buf(512), adl4lbuf(512) -c INTEGER adl4ibuf,adl4ilbuf -c LOGICAL adl4inlbuf -c COMMON /adl4fbuf/adl4buf,adl4lbuf, -c + adl4ibuf,adl4ilbuf,adl4inlbuf - INTEGER*4 adi4buf(512), adi4lbuf(512) - INTEGER adi4ibuf,adi4ilbuf - LOGICAL adi4inlbuf - COMMON /adi4fbuf/adi4buf,adi4lbuf, - + adi4ibuf,adi4ilbuf,adi4inlbuf - INTEGER*8 adi8buf(512), adi8lbuf(512) - INTEGER adi8ibuf,adi8ilbuf - LOGICAL adi8inlbuf - COMMON /adi8fbuf/adi8buf,adi8lbuf, - + adi8ibuf,adi8ilbuf,adi8inlbuf -c INTEGER*16 adi16buf(512), adi16lbuf(512) -c INTEGER adi16ibuf,adi16ilbuf -c LOGICAL adi16inlbuf -c COMMON /adi16fbuf/adi16buf,adi16lbuf, -c + adi16ibuf,adi16ilbuf,adi16inlbuf - REAL*4 adr4buf(512), adr4lbuf(512) - INTEGER adr4ibuf,adr4ilbuf - LOGICAL adr4inlbuf - COMMON /adr4fbuf/adr4buf,adr4lbuf, - + adr4ibuf,adr4ilbuf,adr4inlbuf - REAL*8 adr8buf(512), adr8lbuf(512) - INTEGER adr8ibuf,adr8ilbuf - LOGICAL adr8inlbuf - COMMON /adr8fbuf/adr8buf,adr8lbuf, - + adr8ibuf,adr8ilbuf,adr8inlbuf -c REAL*16 adr16buf(512), adr16lbuf(512) -c INTEGER adr16ibuf,adr16ilbuf -c LOGICAL adr16inlbuf -c COMMON /adr16fbuf/adr16buf,adr16lbuf, -c + adr16ibuf,adr16ilbuf,adr16inlbuf -c REAL*32 x, adr32buf(512), adr32lbuf(512) -c INTEGER adr32ibuf,adr32ilbuf -c LOGICAL adr32inlbuf -c COMMON /adr32fbuf/adr32buf,adr32lbuf, -c + adr32ibuf,adr32ilbuf,adr32inlbuf -c COMPLEX*4 adc4buf(512), adc4lbuf(512) -c INTEGER adc4ibuf,adc4ilbuf -c LOGICAL adc4inlbuf -c COMMON /adc4fbuf/adc4buf,adc4lbuf, -c + adc4ibuf,adc4ilbuf,adc4inlbuf - COMPLEX*8 adc8buf(512), adc8lbuf(512) - INTEGER adc8ibuf,adc8ilbuf - LOGICAL adc8inlbuf - COMMON /adc8fbuf/adc8buf,adc8lbuf, - + adc8ibuf,adc8ilbuf,adc8inlbuf - COMPLEX*16 adc16buf(512), adc16lbuf(512) - INTEGER adc16ibuf,adc16ilbuf - LOGICAL adc16inlbuf - COMMON /adc16fbuf/adc16buf,adc16lbuf, - + adc16ibuf,adc16ilbuf,adc16inlbuf -c COMPLEX*32 adc32buf(512), adc32lbuf(512) -c INTEGER adc32ibuf,adc32ilbuf -c LOGICAL adc32inlbuf -c COMMON /adc32fbuf/adc32buf,adc32lbuf, -c + adc32ibuf,adc32ilbuf,adc32inlbuf - integer*4 bsize,lookbsize - integer*4 cblocks, csize, lookcblocks, lookcsize -c - call getbigcsizes(cblocks,csize,lookcblocks,lookcsize) - write (6,'(a,i8,a,i5,a,i8,a,i5,a)') - + 'MAIN C stack size :',cblocks,'B +',csize, - + ' bytes (looking:',lookcblocks,'B +',lookcsize,')' - bsize = (ads1ibuf-1)*1 - lookbsize = -999 - if (ads1inlbuf.or.ads1ilbuf.gt.-1) lookbsize=(ads1ilbuf-1)*1 - write (6,'(a,i4,a,i4,a)') ' plus CHARs :',bsize, - + ' bytes (looking:',lookbsize,')' -c bsize = (adl4ibuf-1)*4 - bsize = (adi4ibuf-1)*4 - lookbsize = -999 - if (adi4inlbuf.or.adi4ilbuf.gt.-1) lookbsize=(adi4ilbuf-1)*4 - write (6,'(a,i4,a,i4,a)') ' plus INTs4 :',bsize, - + ' bytes (looking:',lookbsize,')' - bsize = (adi8ibuf-1)*8 - lookbsize = -999 - if (adi8inlbuf.or.adi8ilbuf.gt.-1) lookbsize=(adi8ilbuf-1)*8 - write (6,'(a,i4,a,i4,a)') ' plus INTs8 :',bsize, - + ' bytes (looking:',lookbsize,')' -c bsize = (adi16ibuf-1)*16 - bsize = (adr4ibuf-1)*4 - lookbsize = -999 - if (adr4inlbuf.or.adr4ilbuf.gt.-1) lookbsize=(adr4ilbuf-1)*4 - write (6,'(a,i4,a,i4,a)') ' plus REALs4 :',bsize, - + ' bytes (looking:',lookbsize,')' - bsize = (adr8ibuf-1)*8 - lookbsize = -999 - if (adr8inlbuf.or.adr8ilbuf.gt.-1) lookbsize=(adr8ilbuf-1)*8 - write (6,'(a,i4,a,i4,a)') ' plus REALs8 :',bsize, - + ' bytes (looking:',lookbsize,')' -c bsize = (adr16ibuf-1)*16 -c lookbsize = -999 -c if (adr16inlbuf.or.adr16ilbuf.gt.-1) lookbsize=(adr16ilbuf-1)*16 -c write (6,'(a,i4,a,i4,a)') ' plus REALs16 :',bsize, -c + ' bytes (looking:',lookbsize,')' -c bsize = (adr32ibuf-1)*32 -c bsize = (adc4ibuf-1)*4 - bsize = (adc8ibuf-1)*8 - lookbsize = -999 - if (adc8inlbuf.or.adc8ilbuf.gt.-1) lookbsize=(adc8ilbuf-1)*8 - write (6,'(a,i4,a,i4,a)') ' plus CPLXs8 :',bsize, - + ' bytes (looking:',lookbsize,')' - bsize = (adc16ibuf-1)*16 - lookbsize = -999 - if (adc16inlbuf.or.adc16ilbuf.gt.-1) lookbsize=(adc16ilbuf-1)*16 - write (6,'(a,i4,a,i4,a)') ' plus CPLXs16 :',bsize, - + ' bytes (looking:',lookbsize,')' -c bsize = (adc32ibuf-1)*32 -c - end - -C FOR INTERNAL DEBUGS ONLY: - SUBROUTINE SHOWALLSTACKS() - INTEGER*4 adbitbuf, adbitlbuf - INTEGER adbitibuf, adbitilbuf - LOGICAL adbitinlbuf - COMMON /adbitfbuf/adbitbuf,adbitlbuf, - + adbitibuf,adbitilbuf,adbitinlbuf - CHARACTER ads1buf(512), ads1lbuf(512) - INTEGER ads1ibuf,ads1ilbuf - LOGICAL ads1inlbuf - COMMON /ads1fbuf/ads1buf,ads1lbuf, - + ads1ibuf,ads1ilbuf,ads1inlbuf - INTEGER*4 adi4buf(512), adi4lbuf(512) - INTEGER adi4ibuf,adi4ilbuf - LOGICAL adi4inlbuf - COMMON /adi4fbuf/adi4buf,adi4lbuf, - + adi4ibuf,adi4ilbuf,adi4inlbuf - INTEGER*8 adi8buf(512), adi8lbuf(512) - INTEGER adi8ibuf,adi8ilbuf - LOGICAL adi8inlbuf - COMMON /adi8fbuf/adi8buf,adi8lbuf, - + adi8ibuf,adi8ilbuf,adi8inlbuf - REAL*4 adr4buf(512), adr4lbuf(512) - INTEGER adr4ibuf,adr4ilbuf - LOGICAL adr4inlbuf - COMMON /adr4fbuf/adr4buf,adr4lbuf, - + adr4ibuf,adr4ilbuf,adr4inlbuf - REAL*8 adr8buf(512), adr8lbuf(512) - INTEGER adr8ibuf,adr8ilbuf - LOGICAL adr8inlbuf - COMMON /adr8fbuf/adr8buf,adr8lbuf, - + adr8ibuf,adr8ilbuf,adr8inlbuf -c REAL*16 adr16buf(512), adr16lbuf(512) -c INTEGER adr16ibuf,adr16ilbuf -c LOGICAL adr16inlbuf -c COMMON /adr16fbuf/adr16buf,adr16lbuf, -c + adr16ibuf,adr16ilbuf,adr16inlbuf - COMPLEX*8 adc8buf(512), adc8lbuf(512) - INTEGER adc8ibuf,adc8ilbuf - LOGICAL adc8inlbuf - COMMON /adc8fbuf/adc8buf,adc8lbuf, - + adc8ibuf,adc8ilbuf,adc8inlbuf - COMPLEX*16 adc16buf(512), adc16lbuf(512) - INTEGER adc16ibuf,adc16ilbuf - LOGICAL adc16inlbuf - COMMON /adc16fbuf/adc16buf,adc16lbuf, - + adc16ibuf,adc16ilbuf,adc16inlbuf - INTEGER i -c - write (6,1010) 'BIT STACK : ',adbitbuf,'==',adbitbuf, - + ' (',adbitibuf,')' -1010 format(a,i20,a,z16,a,i2,a) - write (6,1011) 'INTEGER*8 BUFFER[',adi8ibuf-1,']: ', - + (adi8buf(i),i=1,adi8ibuf-1) - write (6,1011) 'INTEGER*4 BUFFER[',adi4ibuf-1,']: ', - + (adi4buf(i),i=1,adi4ibuf-1) -1011 format(a,i3,a,512(i40)) -c write (6,1012) 'REAL*16 BUFFER:[',adr16ibuf-1,']: ', -c + (adr16buf(i),i=1,adr16ibuf-1) - write (6,1012) 'REAL*8 BUFFER:[',adr8ibuf-1, ']: ', - + (adr8buf(i),i=1,adr8ibuf-1) - write (6,1012) 'REAL*4 BUFFER:[',adr4ibuf-1, ']: ', - + (adr4buf(i),i=1,adr4ibuf-1) -1012 format(a,i3,a,512(e8.2)) - call showrecentcstack() -c - END - -C======================================================== -C PUSH* POP* SUBROUTINES FOR OTHER DATA TYPES -C Uncomment if these types are available on your compiler -C and they are needed by the reverse differentiated code -C Don't forget to uncomment the corresponding lines in -C subroutine PRINTBUFFERTOP, otherwise these types' -C contribution to buffer occupation will not be seen. -C (not very important anyway...) - -c======================= INTEGER*16 ========================= -c BLOCK DATA INTEGERS16 -c INTEGER*16 adi16buf(512), adi16lbuf(512) -c INTEGER adi16ibuf,adi16ilbuf -c LOGICAL adi16inlbuf -c COMMON /adi16fbuf/adi16buf,adi16lbuf, -c + adi16ibuf,adi16ilbuf,adi16inlbuf -c DATA adi16ibuf/1/ -c DATA adi16ilbuf/-1/ -c DATA adi16inlbuf/.FALSE./ -c END -c c -c SUBROUTINE PUSHINTEGER16(x) -c INTEGER*16 x, adi16buf(512), adi16lbuf(512) -c INTEGER adi16ibuf,adi16ilbuf -c LOGICAL adi16inlbuf -c COMMON /adi16fbuf/adi16buf,adi16lbuf, -c + adi16ibuf,adi16ilbuf,adi16inlbuf -c LOGICAL looking -c COMMON /lookingfbuf/looking -c c -c CALL addftraffic(16) -c IF (adi16ilbuf.ne.-1) THEN -c adi16ilbuf = -1 -c adi16inlbuf = .FALSE. -c looking = .FALSE. -c ENDIF -c IF (adi16ibuf.ge.512) THEN -c adi16buf(512) = x -c CALL PUSHINTEGER16ARRAY(adi16buf, 512) -c CALL addftraffic(-8192) -c adi16ibuf = 1 -c ELSE -c adi16buf(adi16ibuf) = x -c adi16ibuf = adi16ibuf+1 -c ENDIF -c END -c -c SUBROUTINE LOOKINTEGER16(x) -c INTEGER*16 x, adi16buf(512), adi16lbuf(512) -c INTEGER adi16ibuf,adi16ilbuf -c LOGICAL adi16inlbuf -c COMMON /adi16fbuf/adi16buf,adi16lbuf, -c + adi16ibuf,adi16ilbuf,adi16inlbuf -c LOGICAL looking -c COMMON /lookingfbuf/looking -c c -c IF (adi16ilbuf.eq.-1) THEN -c adi16ilbuf=adi16ibuf -c IF (.not.looking) THEN -c CALL RESETADLOOKSTACK() -c looking = .TRUE. -c ENDIF -c ENDIF -c IF (adi16ilbuf.le.1) THEN -c CALL LOOKINTEGER16ARRAY(adi16lbuf, 512) -c adi16inlbuf = .TRUE. -c adi16ilbuf = 512 -c x = adi16lbuf(512) -c ELSE -c adi16ilbuf = adi16ilbuf-1 -c if (adi16inlbuf) THEN -c x = adi16lbuf(adi16ilbuf) -c ELSE -c x = adi16buf(adi16ilbuf) -c ENDIF -c ENDIF -c END -c -c SUBROUTINE POPINTEGER16(x) -c INTEGER*16 x, adi16buf(512), adi16lbuf(512) -c INTEGER adi16ibuf,adi16ilbuf -c LOGICAL adi16inlbuf -c COMMON /adi16fbuf/adi16buf,adi16lbuf, -c + adi16ibuf,adi16ilbuf,adi16inlbuf -c LOGICAL looking -c COMMON /lookingfbuf/looking -c c -c IF (adi16ilbuf.ne.-1) THEN -c adi16ilbuf = -1 -c adi16inlbuf = .FALSE. -c looking = .FALSE. -c ENDIF -c IF (adi16ibuf.le.1) THEN -c CALL POPINTEGER16ARRAY(adi16buf, 512) -c adi16ibuf = 512 -c x = adi16buf(512) -c ELSE -c adi16ibuf = adi16ibuf-1 -c x = adi16buf(adi16ibuf) -c ENDIF -c END - -c======================= REAL*16 ========================= -c BLOCK DATA REALS16 -c REAL*16 adr16buf(512), adr16lbuf(512) -c INTEGER adr16ibuf,adr16ilbuf -c LOGICAL adr16inlbuf -c COMMON /adr16fbuf/adr16buf,adr16lbuf, -c + adr16ibuf,adr16ilbuf,adr16inlbuf -c DATA adr16ibuf/1/ -c DATA adr16ilbuf/-1/ -c DATA adr16inlbuf/.FALSE./ -c END -c -c SUBROUTINE PUSHREAL16(x) -c REAL*16 x, adr16buf(512), adr16lbuf(512) -c INTEGER adr16ibuf,adr16ilbuf -c LOGICAL adr16inlbuf -c COMMON /adr16fbuf/adr16buf,adr16lbuf, -c + adr16ibuf,adr16ilbuf,adr16inlbuf -c LOGICAL looking -c COMMON /lookingfbuf/looking -c c -c CALL addftraffic(16) -c IF (adr16ilbuf.ne.-1) THEN -c adr16ilbuf = -1 -c adr16inlbuf = .FALSE. -c looking = .FALSE. -c ENDIF -c IF (adr16ibuf.ge.512) THEN -c adr16buf(512) = x -c CALL PUSHREAL16ARRAY(adr16buf, 512) -c CALL addftraffic(-8192) -c adr16ibuf = 1 -c ELSE -c adr16buf(adr16ibuf) = x -c adr16ibuf = adr16ibuf+1 -c ENDIF -c END -c -c SUBROUTINE LOOKREAL16(x) -c REAL*16 x, adr16buf(512), adr16lbuf(512) -c INTEGER adr16ibuf,adr16ilbuf -c LOGICAL adr16inlbuf -c COMMON /adr16fbuf/adr16buf,adr16lbuf, -c + adr16ibuf,adr16ilbuf,adr16inlbuf -c LOGICAL looking -c COMMON /lookingfbuf/looking -c c -c IF (adr16ilbuf.eq.-1) THEN -c adr16ilbuf=adr16ibuf -c IF (.not.looking) THEN -c CALL RESETADLOOKSTACK() -c looking = .TRUE. -c ENDIF -c ENDIF -c IF (adr16ilbuf.le.1) THEN -c CALL LOOKREAL16ARRAY(adr16lbuf, 512) -c adr16inlbuf = .TRUE. -c adr16ilbuf = 512 -c x = adr16lbuf(512) -c ELSE -c adr16ilbuf = adr16ilbuf-1 -c if (adr16inlbuf) THEN -c x = adr16lbuf(adr16ilbuf) -c ELSE -c x = adr16buf(adr16ilbuf) -c ENDIF -c ENDIF -c END -c -c SUBROUTINE POPREAL16(x) -c REAL*16 x, adr16buf(512), adr16lbuf(512) -c INTEGER adr16ibuf,adr16ilbuf -c LOGICAL adr16inlbuf -c COMMON /adr16fbuf/adr16buf,adr16lbuf, -c + adr16ibuf,adr16ilbuf,adr16inlbuf -c LOGICAL looking -c COMMON /lookingfbuf/looking -c c -c IF (adr16ilbuf.ne.-1) THEN -c adr16ilbuf = -1 -c adr16inlbuf = .FALSE. -c looking = .FALSE. -c ENDIF -c IF (adr16ibuf.le.1) THEN -c CALL POPREAL16ARRAY(adr16buf, 512) -c adr16ibuf = 512 -c x = adr16buf(512) -c ELSE -c adr16ibuf = adr16ibuf-1 -c x = adr16buf(adr16ibuf) -c ENDIF -c END - -c======================= REAL*32 ========================= -c BLOCK DATA REALS32 -c REAL*32 adr32buf(512), adr32lbuf(512) -c INTEGER adr32ibuf,adr32ilbuf -c LOGICAL adr32inlbuf -c COMMON /adr32fbuf/adr32buf,adr32lbuf, -c + adr32ibuf,adr32ilbuf,adr32inlbuf -c DATA adr32ibuf/1/ -c DATA adr32ilbuf/-1/ -c DATA adr32inlbuf/.FALSE./ -c END -c c -c SUBROUTINE PUSHREAL32(x) -c REAL*32 x, adr32buf(512), adr32lbuf(512) -c INTEGER adr32ibuf,adr32ilbuf -c LOGICAL adr32inlbuf -c COMMON /adr32fbuf/adr32buf,adr32lbuf, -c + adr32ibuf,adr32ilbuf,adr32inlbuf -c LOGICAL looking -c COMMON /lookingfbuf/looking -c c -c CALL addftraffic(32) -c IF (adr32ilbuf.ne.-1) THEN -c adr32ilbuf = -1 -c adr32inlbuf = .FALSE. -c looking = .FALSE. -c ENDIF -c IF (adr32ibuf.ge.512) THEN -c adr32buf(512) = x -c CALL PUSHREAL32ARRAY(adr32buf, 512) -c CALL addftraffic(-16384) -c adr32ibuf = 1 -c ELSE -c adr32buf(adr32ibuf) = x -c adr32ibuf = adr32ibuf+1 -c ENDIF -c END -c -c SUBROUTINE LOOKREAL32(x) -c REAL*32 x, adr32buf(512), adr32lbuf(512) -c INTEGER adr32ibuf,adr32ilbuf -c LOGICAL adr32inlbuf -c COMMON /adr32fbuf/adr32buf,adr32lbuf, -c + adr32ibuf,adr32ilbuf,adr32inlbuf -c LOGICAL looking -c COMMON /lookingfbuf/looking -c c -c IF (adr32ilbuf.eq.-1) THEN -c adr32ilbuf=adr32ibuf -c IF (.not.looking) THEN -c CALL RESETADLOOKSTACK() -c looking = .TRUE. -c ENDIF -c ENDIF -c IF (adr32ilbuf.le.1) THEN -c CALL LOOKREAL32ARRAY(adr32lbuf, 512) -c adr32inlbuf = .TRUE. -c adr32ilbuf = 512 -c x = adr32lbuf(512) -c ELSE -c adr32ilbuf = adr32ilbuf-1 -c if (adr32inlbuf) THEN -c x = adr32lbuf(adr32ilbuf) -c ELSE -c x = adr32buf(adr32ilbuf) -c ENDIF -c ENDIF -c END -c -c SUBROUTINE POPREAL32(x) -c REAL*32 x, adr32buf(512), adr32lbuf(512) -c INTEGER adr32ibuf,adr32ilbuf -c LOGICAL adr32inlbuf -c COMMON /adr32fbuf/adr32buf,adr32lbuf, -c + adr32ibuf,adr32ilbuf,adr32inlbuf -c LOGICAL looking -c COMMON /lookingfbuf/looking -c c -c IF (adr32ilbuf.ne.-1) THEN -c adr32ilbuf = -1 -c adr32inlbuf = .FALSE. -c looking = .FALSE. -c ENDIF -c IF (adr32ibuf.le.1) THEN -c CALL POPREAL32ARRAY(adr32buf, 512) -c adr32ibuf = 512 -c x = adr32buf(512) -c ELSE -c adr32ibuf = adr32ibuf-1 -c x = adr32buf(adr32ibuf) -c ENDIF -c END - -c======================= COMPLEX*4 ========================= -c BLOCK DATA COMPLEXS4 -c COMPLEX*4 adc4buf(512), adc4lbuf(512) -c INTEGER adc4ibuf,adc4ilbuf -c LOGICAL adc4inlbuf -c COMMON /adc4fbuf/adc4buf,adc4lbuf, -c + adc4ibuf,adc4ilbuf,adc4inlbuf -c DATA adc4ibuf/1/ -c DATA adc4ilbuf/-1/ -c DATA adc4inlbuf/.FALSE./ -c END -c c -c SUBROUTINE PUSHCOMPLEX4(x) -c COMPLEX*4 x, adc4buf(512), adc4lbuf(512) -c INTEGER adc4ibuf,adc4ilbuf -c LOGICAL adc4inlbuf -c COMMON /adc4fbuf/adc4buf,adc4lbuf, -c + adc4ibuf,adc4ilbuf,adc4inlbuf -c LOGICAL looking -c COMMON /lookingfbuf/looking -c c -c CALL addftraffic(4) -c IF (adc4ilbuf.ne.-1) THEN -c adc4ilbuf = -1 -c adc4inlbuf = .FALSE. -c looking = .FALSE. -c ENDIF -c IF (adc4ibuf.ge.512) THEN -c adc4buf(512) = x -c CALL PUSHCOMPLEX4ARRAY(adc4buf, 512) -c CALL addftraffic(-2048) -c adc4ibuf = 1 -c ELSE -c adc4buf(adc4ibuf) = x -c adc4ibuf = adc4ibuf+1 -c ENDIF -c END -c -c SUBROUTINE LOOKCOMPLEX4(x) -c COMPLEX*4 x, adc4buf(512), adc4lbuf(512) -c INTEGER adc4ibuf,adc4ilbuf -c LOGICAL adc4inlbuf -c COMMON /adc4fbuf/adc4buf,adc4lbuf, -c + adc4ibuf,adc4ilbuf,adc4inlbuf -c LOGICAL looking -c COMMON /lookingfbuf/looking -c c -c IF (adc4ilbuf.eq.-1) THEN -c adc4ilbuf=adc4ibuf -c IF (.not.looking) THEN -c CALL RESETADLOOKSTACK() -c looking = .TRUE. -c ENDIF -c ENDIF -c IF (adc4ilbuf.le.1) THEN -c CALL LOOKCOMPLEX4ARRAY(adc4lbuf, 512) -c adc4inlbuf = .TRUE. -c adc4ilbuf = 512 -c x = adc4lbuf(512) -c ELSE -c adc4ilbuf = adc4ilbuf-1 -c if (adc4inlbuf) THEN -c x = adc4lbuf(adc4ilbuf) -c ELSE -c x = adc4buf(adc4ilbuf) -c ENDIF -c ENDIF -c END -c -c SUBROUTINE POPCOMPLEX4(x) -c COMPLEX*4 x, adc4buf(512), adc4lbuf(512) -c INTEGER adc4ibuf,adc4ilbuf -c LOGICAL adc4inlbuf -c COMMON /adc4fbuf/adc4buf,adc4lbuf, -c + adc4ibuf,adc4ilbuf,adc4inlbuf -c LOGICAL looking -c COMMON /lookingfbuf/looking -c c -c IF (adc4ilbuf.ne.-1) THEN -c adc4ilbuf = -1 -c adc4inlbuf = .FALSE. -c looking = .FALSE. -c ENDIF -c IF (adc4ibuf.le.1) THEN -c CALL POPCOMPLEX4ARRAY(adc4buf, 512) -c adc4ibuf = 512 -c x = adc4buf(512) -c ELSE -c adc4ibuf = adc4ibuf-1 -c x = adc4buf(adc4ibuf) -c ENDIF -c END - -c======================= COMPLEX*32 ========================= -c BLOCK DATA COMPLEXS32 -c COMPLEX*32 adc32buf(512), adc32lbuf(512) -c INTEGER adc32ibuf,adc32ilbuf -c LOGICAL adc32inlbuf -c COMMON /adc32fbuf/adc32buf,adc32lbuf, -c + adc32ibuf,adc32ilbuf,adc32inlbuf -c DATA adc32ibuf/1/ -c DATA adc32ilbuf/-1/ -c DATA adc32inlbuf/.FALSE./ -c END -c c -c SUBROUTINE PUSHCOMPLEX32(x) -c COMPLEX*32 x, adc32buf(512), adc32lbuf(512) -c INTEGER adc32ibuf,adc32ilbuf -c LOGICAL adc32inlbuf -c COMMON /adc32fbuf/adc32buf,adc32lbuf, -c + adc32ibuf,adc32ilbuf,adc32inlbuf -c LOGICAL looking -c COMMON /lookingfbuf/looking -c c -c CALL addftraffic(32) -c IF (adc32ilbuf.ne.-1) THEN -c adc32ilbuf = -1 -c adc32inlbuf = .FALSE. -c looking = .FALSE. -c ENDIF -c IF (adc32ibuf.ge.512) THEN -c adc32buf(512) = x -c CALL PUSHCOMPLEX32ARRAY(adc32buf, 512) -c CALL addftraffic(-16384) -c adc32ibuf = 1 -c ELSE -c adc32buf(adc32ibuf) = x -c adc32ibuf = adc32ibuf+1 -c ENDIF -c END -c -c SUBROUTINE LOOKCOMPLEX32(x) -c COMPLEX*32 x, adc32buf(512), adc32lbuf(512) -c INTEGER adc32ibuf,adc32ilbuf -c LOGICAL adc32inlbuf -c COMMON /adc32fbuf/adc32buf,adc32lbuf, -c + adc32ibuf,adc32ilbuf,adc32inlbuf -c LOGICAL looking -c COMMON /lookingfbuf/looking -c c -c IF (adc32ilbuf.eq.-1) THEN -c adc32ilbuf=adc32ibuf -c IF (.not.looking) THEN -c CALL RESETADLOOKSTACK() -c looking = .TRUE. -c ENDIF -c ENDIF -c IF (adc32ilbuf.le.1) THEN -c CALL LOOKCOMPLEX32ARRAY(adc32lbuf, 512) -c adc32inlbuf = .TRUE. -c adc32ilbuf = 512 -c x = adc32lbuf(512) -c ELSE -c adc32ilbuf = adc32ilbuf-1 -c if (adc32inlbuf) THEN -c x = adc32lbuf(adc32ilbuf) -c ELSE -c x = adc32buf(adc32ilbuf) -c ENDIF -c ENDIF -c END -c -c SUBROUTINE POPCOMPLEX32(x) -c COMPLEX*32 x, adc32buf(512), adc32lbuf(512) -c INTEGER adc32ibuf,adc32ilbuf -c LOGICAL adc32inlbuf -c COMMON /adc32fbuf/adc32buf,adc32lbuf, -c + adc32ibuf,adc32ilbuf,adc32inlbuf -c LOGICAL looking -c COMMON /lookingfbuf/looking -c c -c IF (adc32ilbuf.ne.-1) THEN -c adc32ilbuf = -1 -c adc32inlbuf = .FALSE. -c looking = .FALSE. -c ENDIF -c IF (adc32ibuf.le.1) THEN -c CALL POPCOMPLEX32ARRAY(adc32buf, 512) -c adc32ibuf = 512 -c x = adc32buf(512) -c ELSE -c adc32ibuf = adc32ibuf-1 -c x = adc32buf(adc32ibuf) -c ENDIF -c END - -C======================================================== -C HOW TO CREATE PUSH* POP* SUBROUTINES -C YET FOR OTHER DATA TYPES -C ** Duplicate the commented program lines below -c ** In the duplicated subroutines, replace: -c TTTT by the basic name of the type -c z9 by the initial and size of the type -c (integer:i real:r complex:c boolean:b character:s) -c 9 by the size of the type -c ** Uncomment the duplicated subroutines -C ** Don't forget to insert the corresponding lines in -C subroutine PRINTBUFFERTOP, otherwise these types' -C contribution to buffer occupation will not be seen. -C (not very important anyway...) - -c======================= TTTT*9 ========================= -c BLOCK DATA TTTTS9 -c TTTT*9 adz9buf(512), adz9lbuf(512) -c INTEGER adz9ibuf,adz9ilbuf -c LOGICAL adz9inlbuf -c COMMON /adz9fbuf/adz9buf,adz9lbuf, -c + adz9ibuf,adz9ilbuf,adz9inlbuf -c DATA adz9ibuf/1/ -c DATA adz9ilbuf/-1/ -c DATA adz9inlbuf/.FALSE./ -c END -c c -c SUBROUTINE PUSHTTTT9(x) -c TTTT*9 x, adz9buf(512), adz9lbuf(512) -c INTEGER adz9ibuf,adz9ilbuf -c LOGICAL adz9inlbuf -c COMMON /adz9fbuf/adz9buf,adz9lbuf, -c + adz9ibuf,adz9ilbuf,adz9inlbuf -c LOGICAL looking -c COMMON /lookingfbuf/looking -c c -c CALL addftraffic(9) -c IF (adz9ilbuf.ne.-1) THEN -c adz9ilbuf = -1 -c adz9inlbuf = .FALSE. -c looking = .FALSE. -c ENDIF -c IF (adz9ibuf.ge.512) THEN -c adz9buf(512) = x -c CALL PUSHTTTT9ARRAY(adz9buf, 512) -c CALL addftraffic(-9*512) -c adz9ibuf = 1 -c ELSE -c adz9buf(adz9ibuf) = x -c adz9ibuf = adz9ibuf+1 -c ENDIF -c END -c -c SUBROUTINE LOOKTTTT9(x) -c TTTT*9 x, adz9buf(512), adz9lbuf(512) -c INTEGER adz9ibuf,adz9ilbuf -c LOGICAL adz9inlbuf -c COMMON /adz9fbuf/adz9buf,adz9lbuf, -c + adz9ibuf,adz9ilbuf,adz9inlbuf -c LOGICAL looking -c COMMON /lookingfbuf/looking -c c -c IF (adz9ilbuf.eq.-1) THEN -c adz9ilbuf=adz9ibuf -c IF (.not.looking) THEN -c CALL RESETADLOOKSTACK() -c looking = .TRUE. -c ENDIF -c ENDIF -c IF (adz9ilbuf.le.1) THEN -c CALL LOOKTTTT9ARRAY(adz9lbuf, 512) -c adz9inlbuf = .TRUE. -c adz9ilbuf = 512 -c x = adz9lbuf(512) -c ELSE -c adz9ilbuf = adz9ilbuf-1 -c if (adz9inlbuf) THEN -c x = adz9lbuf(adz9ilbuf) -c ELSE -c x = adz9buf(adz9ilbuf) -c ENDIF -c ENDIF -c END -c -c SUBROUTINE POPTTTT9(x) -c TTTT*9 x, adz9buf(512), adz9lbuf(512) -c INTEGER adz9ibuf,adz9ilbuf -c LOGICAL adz9inlbuf -c COMMON /adz9fbuf/adz9buf,adz9lbuf, -c + adz9ibuf,adz9ilbuf,adz9inlbuf -c LOGICAL looking -c COMMON /lookingfbuf/looking -c c -c IF (adz9ilbuf.ne.-1) THEN -c adz9ilbuf = -1 -c adz9inlbuf = .FALSE. -c looking = .FALSE. -c ENDIF -c IF (adz9ibuf.le.1) THEN -c CALL POPTTTT9ARRAY(adz9buf, 512) -c adz9ibuf = 512 -c x = adz9buf(512) -c ELSE -c adz9ibuf = adz9ibuf-1 -c x = adz9buf(adz9ibuf) -c ENDIF -c END diff --git a/src/adjoint/adStack.c b/src/adjoint/adStack.c index c57a1ed..ae0cae8 100644 --- a/src/adjoint/adStack.c +++ b/src/adjoint/adStack.c @@ -1,52 +1,215 @@ -static char adSid[]="$Id: adStack.c 5951 2016-02-09 12:22:02Z llh $"; - #include #include #include -/* The size of a BLOCK in characters */ -#define ONE_BLOCK_SIZE 16384 -#ifndef STACK_SIZE_TRACING -#define STACK_SIZE_TRACING 1 -#endif +/* The size of a BLOCK in characters. Suggested 16384. Should try 2^16=65536 */ +#define ONE_BLOCK_SIZE 65536 + /* The main stack is a double-chain of DoubleChainedBlock objects. * Each DoubleChainedBlock holds an array[ONE_BLOCK_SIZE] of char. */ -typedef struct _doubleChainedBlock{ - struct _doubleChainedBlock *prev ; +typedef struct _DoubleChainedBlock{ + unsigned int rank ; + struct _DoubleChainedBlock *prev ; char *contents ; - struct _doubleChainedBlock *next ; + struct _DoubleChainedBlock *next ; } DoubleChainedBlock ; -/* Globals that define the current position in the stack: */ -static DoubleChainedBlock *curStack = NULL ; -static char *curStackTop = NULL ; -/* Globals that define the current LOOKing position in the stack: */ -static DoubleChainedBlock *lookStack = NULL ; -static char *lookStackTop = NULL ; +char initContents[ONE_BLOCK_SIZE] = {'\0'} ; +DoubleChainedBlock initBlock = {0,NULL,initContents,NULL} ; +static DoubleChainedBlock *curStack = &initBlock ; +static char *curStackTop = initContents ; + +static unsigned long int maintraffic = 0 ; + +void setCurLocation(unsigned long int location) { + unsigned int targetRank = (unsigned int)location/ONE_BLOCK_SIZE ; + unsigned int targetOffset = (unsigned int)location%ONE_BLOCK_SIZE ; + if (targetRank>curStack->rank) + while (targetRank>curStack->rank) curStack = curStack->next ; + else if (targetRankrank) + while (targetRankrank) curStack = curStack->prev ; + curStackTop = curStack->contents + targetOffset ; +} + +unsigned long int getCurLocation() { + return (curStackTop-curStack->contents)+curStack->rank*ONE_BLOCK_SIZE ; +} + +void showLocation(unsigned long int location) { + printf("%1i.%05i", (unsigned int)location/ONE_BLOCK_SIZE, (unsigned int)location%ONE_BLOCK_SIZE) ; +} + +/*************** REPEATED ACCESS MECHANISM *********************/ + +typedef struct _StackRepeatCell { + int hasBackPop ; + unsigned long int backPop ; + unsigned long int resume ; + unsigned long int freePush ; + struct _StackRepeatCell *previous ; +} StackRepeatCell ; + +StackRepeatCell *stackRepeatTop = NULL ; + +void showStackRepeatsRec(StackRepeatCell *inRepeatStack) { + if (inRepeatStack->previous) {showStackRepeatsRec(inRepeatStack->previous) ; printf(" ; ") ;} + printf("<") ; + if (inRepeatStack->hasBackPop) showLocation(inRepeatStack->backPop) ; + printf("|") ; + showLocation(inRepeatStack->resume) ; + printf("|") ; + showLocation(inRepeatStack->freePush) ; + printf(">") ; +} + +void showStackRepeats() { + showStackRepeatsRec(stackRepeatTop) ; +} + +void showStack() { + DoubleChainedBlock *inStack = &initBlock ; + int i ; + while (inStack) { + printf("[%1i] ",inStack->rank) ; + for (i=0 ; icontents[i])==curStackTop) printf(" | ") ; + printf("%02x",(unsigned char)inStack->contents[i]) ; + } + inStack = inStack->next ; + if (inStack) printf("\n ") ; + } + printf("\n REPEATS:") ; + if (stackRepeatTop) + showStackRepeats() ; + else + printf(" none!") ; + printf("\n") ; +} + +void showStackSize(int i4i, int i8i, int r4i, int r8i, int c8i, int c16i, int s1i, int biti, int ptri) { + printf(" --> <") ; + showLocation(getCurLocation()) ; + printf(">%1i.%1i.%1i.%1i.%1i.%1i.%1i.%1i.%1i\n",i4i, i8i, r4i, r8i, c8i, c16i, s1i, biti, ptri) ; +} + +void adStack_showPeakSize() { + DoubleChainedBlock *inStack = &initBlock ; + int i = 0 ; + while (inStack) { + inStack = inStack->next ; + ++i ; + } + printf("Peak stack size (%1i blocks): %1llu bytes\n", + i, ((long long int)i)*((long long int)ONE_BLOCK_SIZE)) ; +} + +void showTotalTraffic(unsigned long long int localtraffic) { + printf("Total pushed traffic %1llu bytes\n", maintraffic+localtraffic) ; +} + +/** If we are in a protected, read-only section, memorize location as "backPop" + * and go to the "freePush" location */ +void checkPushInReadOnly() { + if (stackRepeatTop) { + unsigned long int current = getCurLocation() ; + if (currentfreePush) { + stackRepeatTop->hasBackPop = 1 ; + stackRepeatTop->backPop = current ; + setCurLocation(stackRepeatTop->freePush) ; +/* printf(" FREEPUSH(") ; //Trace */ +/* showLocation(stackRepeatTop->backPop) ; //Trace */ +/* printf("=>") ; //Trace */ +/* showLocation(stackRepeatTop->freePush) ; //Trace */ +/* printf(")") ; //Trace */ + } + } +} + +/** If current location is the "freePush" location, + * go back to its "backPop" location, which is in a protected, read-only section */ +void checkPopToReadOnly() { + if (stackRepeatTop && stackRepeatTop->hasBackPop) { + unsigned long int current = getCurLocation() ; + if (current==stackRepeatTop->freePush) { + setCurLocation(stackRepeatTop->backPop) ; + stackRepeatTop->hasBackPop = 0 ; +/* printf(" BACKPOP(") ; //Trace */ +/* showLocation(stackRepeatTop->freePush) ; //Trace */ +/* printf("=>") ; //Trace */ +/* showLocation(stackRepeatTop->backPop) ; //Trace */ +/* printf(")") ; //Trace */ + } + } +} + +// A global for communication from startStackRepeat1() to startStackRepeat2(): +StackRepeatCell *newRepeatCell = NULL ; + +void startStackRepeat1() { + // Create (push) a new "stack" repeat level: + newRepeatCell = (StackRepeatCell *)malloc(sizeof(StackRepeatCell)) ; + newRepeatCell->previous = stackRepeatTop ; + newRepeatCell->hasBackPop = 0 ; + // Store current location as the "resume" location: + unsigned long int current = getCurLocation() ; + newRepeatCell->resume = current ; + // Move to the "freePush" location if there is one: + if (stackRepeatTop && currentfreePush) + setCurLocation(stackRepeatTop->freePush) ; +} + +void startStackRepeat2() { + // Store current stack location as the "freePush" location: + newRepeatCell->freePush = getCurLocation() ; + // Reset current location to stored "resume" location: + setCurLocation(newRepeatCell->resume) ; + // Make this new repeat level the current repeat level: + stackRepeatTop = newRepeatCell ; +/* printf("\n+Rep ") ; showStackRepeats() ; printf("\n") ; //Trace */ +} + +void resetStackRepeat1() { +/* printf("\n>Rep ") ; showStackRepeats() ; printf("\n") ; //Trace */ + // If we are in a nested checkpoint, force exit from it: + if (stackRepeatTop->hasBackPop) { + //setCurLocation(stackRepeatTop->backPop) ; //correct but useless code + stackRepeatTop->hasBackPop = 0 ; + } + // Go to repeat location of current repeat level + setCurLocation(stackRepeatTop->freePush) ; +} + +void resetStackRepeat2() { + // Reset current location to "ResumeLocation": + setCurLocation(stackRepeatTop->resume) ; +} + +void endStackRepeat() { +/* printf("\n-Rep ") ; showStackRepeats() ; printf("\n") ; //Trace */ + // If we are in a nested checkpoint, go back to its "backPop" (read-only) location: + if (stackRepeatTop->hasBackPop) { + setCurLocation(stackRepeatTop->backPop) ; + //stackRepeatTop->hasBackPop = 0 ; //correct but useless code + } + // Remove (pop) top "stack" repeat level: + StackRepeatCell *oldRepeatCell = stackRepeatTop ; + stackRepeatTop = stackRepeatTop->previous ; + free(oldRepeatCell) ; + // current location may have moved back ; check if we must move further back: + checkPopToReadOnly() ; +} -static long int mmctraffic = 0 ; -static long int mmctrafficM = 0 ; -#ifdef STACK_SIZE_TRACING -long int bigStackSize = 0; -#endif +/******************* PUSH/POP MECHANISM *******************/ /* PUSHes "nbChars" consecutive chars from a location starting at address "x". - * Resets the LOOKing position if it was active. * Checks that there is enough space left to hold "nbChars" chars. * Otherwise, allocates the necessary space. */ -void pushNarray(char *x, unsigned int nbChars) { - unsigned int nbmax = (curStack)?ONE_BLOCK_SIZE-(curStackTop-(curStack->contents)):0 ; -#ifdef STACK_SIZE_TRACING - bigStackSize += nbChars; -#endif - - mmctraffic += nbChars ; - while (mmctraffic >= 1000000) { - mmctraffic -= 1000000 ; - mmctrafficM++ ; - } - - lookStack = NULL ; +void pushNArray(char *x, unsigned int nbChars, int checkReadOnly) { + if (checkReadOnly) checkPushInReadOnly() ; + if (checkReadOnly) maintraffic += nbChars ; +/* unsigned long int lfrom = getCurLocation() ; //Trace */ + unsigned int nbmax = ONE_BLOCK_SIZE-(curStackTop-(curStack->contents)) ; if (nbChars <= nbmax) { memcpy(curStackTop,x,nbChars) ; curStackTop+=nbChars ; @@ -54,7 +217,9 @@ void pushNarray(char *x, unsigned int nbChars) { char *inx = x+(nbChars-nbmax) ; if (nbmax>0) memcpy(curStackTop,inx,nbmax) ; while (inx>x) { - if ((curStack == NULL) || (curStack->next == NULL)) { + if (curStack->next) + curStack = curStack->next ; + else { /* Create new block: */ DoubleChainedBlock *newStack ; char *contents = (char *)malloc(ONE_BLOCK_SIZE*sizeof(char)) ; @@ -70,14 +235,14 @@ void pushNarray(char *x, unsigned int nbChars) { nbBlocks, ONE_BLOCK_SIZE) ; exit(0); } - if (curStack != NULL) curStack->next = newStack ; + curStack->next = newStack ; newStack->prev = curStack ; + newStack->rank = curStack->rank + 1 ; newStack->next = NULL ; newStack->contents = contents ; curStack = newStack ; /* new block created! */ - } else - curStack = curStack->next ; + } inx -= ONE_BLOCK_SIZE ; if(inx>x) memcpy(curStack->contents,inx,ONE_BLOCK_SIZE) ; @@ -89,18 +254,20 @@ void pushNarray(char *x, unsigned int nbChars) { } } } +/* unsigned long int lto = getCurLocation() ; //Trace */ +/* printf("pushNArray(") ; //Trace */ +/* showLocation(lfrom) ; //Trace */ +/* printf("=>") ; //Trace */ +/* showLocation(lto) ; //Trace */ +/* printf(")") ; //Trace */ } /* POPs "nbChars" consecutive chars to a location starting at address "x". - * Resets the LOOKing position if it was active. * Checks that there is enough data to fill "nbChars" chars. * Otherwise, pops as many blocks as necessary. */ -void popNarray(char *x, unsigned int nbChars) { +void popNArray(char *x, unsigned int nbChars, int checkReadOnly) { +/* unsigned long int lfrom = getCurLocation() ; //Trace */ unsigned int nbmax = curStackTop-(curStack->contents) ; -#ifdef STACK_SIZE_TRACING - bigStackSize -= nbChars; -#endif - lookStack = NULL ; if (nbChars <= nbmax) { curStackTop-=nbChars ; memcpy(x,curStackTop,nbChars); @@ -116,601 +283,237 @@ void popNarray(char *x, unsigned int nbChars) { x += ONE_BLOCK_SIZE ; } else { unsigned int nbtail = tlx-x ; - curStackTop=(curStack->contents)+ONE_BLOCK_SIZE-nbtail ; + curStackTop = (curStack->contents)+ONE_BLOCK_SIZE-nbtail ; memcpy(x,curStackTop,nbtail) ; x = tlx ; } } } +/* unsigned long int lto = getCurLocation() ; //Trace */ +/* printf("popNArray(") ; //Trace */ +/* showLocation(lfrom) ; //Trace */ +/* printf("=>") ; //Trace */ +/* showLocation(lto) ; //Trace */ +/* printf(")") ; //Trace */ + if (checkReadOnly) checkPopToReadOnly() ; } -/* LOOKs "nbChars" consecutive chars to a location starting at address "x". - * Activates the LOOKing position if it was reset. - * LOOKing is just like POPping, except that the main pointer - * remains in place, so that the value is not POPped. - * Further PUSHs or POPs will start from the same place as if - * no LOOK had been made. */ -void lookNarray(char *x, unsigned int nbChars) { - unsigned int nbmax ; - if (lookStack == NULL) { - lookStack = curStack ; - lookStackTop = curStackTop ; - } - nbmax = lookStackTop-(lookStack->contents) ; - if (nbChars <= nbmax) { - lookStackTop-=nbChars ; - memcpy(x,lookStackTop,nbChars); - } else { - char *tlx = x+nbChars ; - if (nbmax>0) memcpy(x,lookStack->contents,nbmax) ; - x+=nbmax ; - while (xprev ; - if (lookStack==NULL) printf("Looking into an empty stack!!!") ; - if (x+ONE_BLOCK_SIZEcontents,ONE_BLOCK_SIZE) ; - x += ONE_BLOCK_SIZE ; - } else { - unsigned int nbtail = tlx-x ; - lookStackTop=(lookStack->contents)+ONE_BLOCK_SIZE-nbtail ; - memcpy(x,lookStackTop,nbtail) ; - x = tlx ; - } - } - } -} +typedef struct {float r,i;} ccmplx ; +typedef struct {double dr, di;} cdcmplx ; -void resetadlookstack_() { - lookStack=NULL ; +void pushInteger4Array(int *x, int n) { + pushNArray((char *)x,(unsigned int)(n*4), 1) ; } -/****** Exported PUSH/POP/LOOK functions for ARRAYS: ******/ -/* --> Called from FORTRAN: */ - -void pushcharacterarray_(char *x, unsigned int *n) { - pushNarray(x,*n) ; -} -void popcharacterarray_(char *x, unsigned int *n) { - popNarray(x,*n) ; -} -void lookcharacterarray_(char *x, unsigned int *n) { - lookNarray(x,*n) ; +void popInteger4Array(int *x, int n) { + popNArray((char *)x,(unsigned int)(n*4), 1) ; } -void pushbooleanarray_(char *x, unsigned int *n) { - pushNarray(x,(*n*4)) ; -} -void popbooleanarray_(char *x, unsigned int *n) { - popNarray(x,(*n*4)) ; -} -void lookbooleanarray_(char *x, unsigned int *n) { - lookNarray(x,(*n*4)) ; +void pushInteger8Array(long *x, int n) { + pushNArray((char *)x,(unsigned int)(n*8), 1) ; } -void pushinteger4array_(void *x, unsigned int *n) { - pushNarray((char *)x,(*n*4)) ; -} -void popinteger4array_(void *x, unsigned int *n) { - popNarray((char *)x,(*n*4)) ; -} -void lookinteger4array_(void *x, unsigned int *n) { - lookNarray((char *)x,(*n*4)) ; +void popInteger8Array(long *x, int n) { + popNArray((char *)x,(unsigned int)(n*8), 1) ; } -void pushinteger8array_(void *x, unsigned int *n) { - pushNarray((char *)x,(*n*8)) ; -} -void popinteger8array_(void *x, unsigned int *n) { - popNarray((char *)x,(*n*8)) ; -} -void lookinteger8array_(void *x, unsigned int *n) { - lookNarray((char *)x,(*n*8)) ; +void pushReal4Array(float *x, int n) { + pushNArray((char *)x,(unsigned int)(n*4), 1) ; } -void pushinteger16array_(void *x, unsigned int *n) { - pushNarray((char *)x,(*n*16)) ; -} -void popinteger16array_(void *x, unsigned int *n) { - popNarray((char *)x,(*n*16)) ; -} -void lookinteger16array_(void *x, unsigned int *n) { - lookNarray((char *)x,(*n*16)) ; +void popReal4Array(float *x, int n) { + popNArray((char *)x,(unsigned int)(n*4), 1) ; } -void pushreal4array_(void *x, unsigned int *n) { - pushNarray((char *)x,(*n*4)) ; -} -void popreal4array_(void *x, unsigned int *n) { - popNarray((char *)x,(*n*4)) ; -} -void lookreal4array_(void *x, unsigned int *n) { - lookNarray((char *)x,(*n*4)) ; +void pushReal8Array(double *x, int n) { + pushNArray((char *)x,(unsigned int)(n*8), 1) ; } -void pushreal8array_(void *x, unsigned int *n) { - pushNarray((char *)x,(*n*8)) ; -} -void popreal8array_(void *x, unsigned int *n) { - popNarray((char *)x,(*n*8)) ; -} -void lookreal8array_(void *x, unsigned int *n) { - lookNarray((char *)x,(*n*8)) ; +void popReal8Array(double *x, int n) { + popNArray((char *)x,(unsigned int)(n*8), 1) ; } -void pushreal16array_(void *x, unsigned int *n) { - pushNarray((char *)x,(*n*16)) ; -} -void popreal16array_(void *x, unsigned int *n) { - popNarray((char *)x,(*n*16)) ; -} -void lookreal16array_(void *x, unsigned int *n) { - lookNarray((char *)x,(*n*16)) ; +void pushComplex8Array(ccmplx *x, int n) { + pushNArray((char *)x,(unsigned int)(n*8), 1) ; } -void pushreal32array_(void *x, unsigned int *n) { - pushNarray((char *)x,(*n*32)) ; -} -void popreal32array_(void *x, unsigned int *n) { - popNarray((char *)x,(*n*32)) ; -} -void lookreal32array_(void *x, unsigned int *n) { - lookNarray((char *)x,(*n*32)) ; +void popComplex8Array(ccmplx *x, int n) { + popNArray((char *)x,(unsigned int)(n*8), 1) ; } -void pushcomplex4array_(void *x, unsigned int *n) { - pushNarray((char *)x,(*n*4)) ; -} -void popcomplex4array_(void *x, unsigned int *n) { - popNarray((char *)x,(*n*4)) ; -} -void lookcomplex4array_(void *x, unsigned int *n) { - lookNarray((char *)x,(*n*4)) ; +void pushComplex16Array(cdcmplx *x, int n) { + pushNArray((char *)x,(unsigned int)(n*16), 1) ; } -void pushcomplex8array_(void *x, unsigned int *n) { - pushNarray((char *)x,(*n*8)) ; -} -void popcomplex8array_(void *x, unsigned int *n) { - popNarray((char *)x,(*n*8)) ; -} -void lookcomplex8array_(void *x, unsigned int *n) { - lookNarray((char *)x,(*n*8)) ; +void popComplex16Array(cdcmplx *x, int n) { + popNArray((char *)x,(unsigned int)(n*16), 1) ; } -void pushcomplex16array_(void *x, unsigned int *n) { - pushNarray((char *)x,(*n*16)) ; -} -void popcomplex16array_(void *x, unsigned int *n) { - popNarray((char *)x,(*n*16)) ; -} -void lookcomplex16array_(void *x, unsigned int *n) { - lookNarray((char *)x,(*n*16)) ; +void pushCharacterArray(char *x, int n) { + pushNArray(x,(unsigned int)n, 1) ; } -void pushcomplex32array_(void *x, unsigned int *n) { - pushNarray((char *)x,(*n*32)) ; -} -void popcomplex32array_(void *x, unsigned int *n) { - popNarray((char *)x,(*n*32)) ; -} -void lookcomplex32array_(void *x, unsigned int *n) { - lookNarray((char *)x,(*n*32)) ; +void popCharacterArray(char *x, int n) { + popNArray(x,(unsigned int)n, 1) ; } -/****** Exported PUSH/POP/LOOK functions for F95 POINTERS: ******/ +/* ********* Useful only for testpushpop.f90. Should go away! ********* */ -void pushpointer4_(void *ppp) { - pushNarray((char *)ppp, 4) ; +void showpushpopsequence_(int *op, int *index, int* nbobjects, int* sorts, int* sizes) { + char *prefix = "" ; + if (*op==1) prefix = "+" ; + else if (*op==-1) prefix = "-" ; + else if (*op==2) prefix = "+s" ; + else if (*op==-2) prefix = "-s" ; + else if (*op==-3) prefix = "Ls" ; + printf("%s%02i", prefix, *index) ; + // Comment the rest for compact display: + printf(":") ; + int i ; + for (i=0 ; i<*nbobjects ; ++i) { + switch (sorts[i]) { + case 1: + printf(" I4") ; + break ; + case 2: + printf(" I8") ; + break ; + case 3: + printf(" R4") ; + break ; + case 4: + printf(" R8") ; + break ; + case 5: + printf(" C8") ; + break ; + case 6: + printf(" C16") ; + break ; + case 7: + printf(" char") ; + break ; + case 8: + printf(" bit") ; + break ; + case 9: + printf(" PTR") ; + break ; + } + if (sizes[i]!=0) printf("[%1i]",sizes[i]) ; + } } -void lookpointer4_(void *ppp) { - lookNarray((char *)ppp, 4) ; -} +/****************** INTERFACE CALLED FROM FORTRAN *******************/ -void poppointer4_(void *ppp) { - popNarray((char *)ppp, 4) ; +void showstack_() { + showStack() ; } -void pushpointer8_(void *ppp) { - pushNarray((char *)ppp, 8) ; +void showstacksize_(int *i4i, int *i8i, int *r4i, int *r8i, int *c8i, int *c16i, int *s1i, int *biti, int *ptri) { + showStackSize(*i4i,*i8i,*r4i,*r8i,*c8i,*c16i,*s1i,*biti,*ptri) ; } -void lookpointer8_(void *ppp) { - lookNarray((char *)ppp, 8) ; +void adstack_showpeaksize_() { + adStack_showPeakSize() ; } -void poppointer8_(void *ppp) { - popNarray((char *)ppp, 8) ; +void adstack_showpeaksize__() { + adStack_showPeakSize() ; } -/* --> Called from C: */ - -void pushcharacterarray(char *x, int n) { - pushNarray(x,(unsigned int)n) ; -} -void popcharacterarray(char *x, int n) { - popNarray(x,(unsigned int)n) ; -} -void lookcharacterarray(char *x, int n) { - lookNarray(x,(unsigned int)n) ; +void showtotaltraffic_(unsigned long long int *traffic) { + showTotalTraffic(*traffic) ; } -void pushbooleanarray(char *x, int n) { - pushNarray(x,(unsigned int)(n*4)) ; -} -void popbooleanarray(char *x, int n) { - popNarray(x,(unsigned int)(n*4)) ; -} -void lookbooleanarray(char *x, int n) { - lookNarray(x,(unsigned int)(n*4)) ; +void startstackrepeat1_() { + startStackRepeat1() ; } -void pushinteger4array(int *x, int n) { - pushNarray((char *)x,(unsigned int)(n*4)) ; -} -void popinteger4array(int *x, int n) { - popNarray((char *)x,(unsigned int)(n*4)) ; -} -void lookinteger4array(int *x, int n) { - lookNarray((char *)x,(unsigned int)(n*4)) ; +void startstackrepeat2_() { + startStackRepeat2() ; } -void pushinteger8array(long int *x, int n) { - pushNarray((char *)x,(unsigned int)(n*8)) ; -} -void popinteger8array(long int *x, int n) { - popNarray((char *)x,(unsigned int)(n*8)) ; -} -void lookinteger8array(long int *x, int n) { - lookNarray((char *)x,(unsigned int)(n*8)) ; +void resetstackrepeat1_() { + resetStackRepeat1() ; } -void pushinteger16array(long long int *x, int n) { - pushNarray((char *)x,(unsigned int)(n*16)) ; -} -void popinteger16array(long long int *x, int n) { - popNarray((char *)x,(unsigned int)(n*16)) ; -} -void lookinteger16array(long long int *x, int n) { - lookNarray((char *)x,(unsigned int)(n*16)) ; +void resetstackrepeat2_() { + resetStackRepeat2() ; } -void pushreal4array(float *x, int n) { - pushNarray((char *)x, (unsigned int)(n*4)) ; -} -void popreal4array(float *x, int n) { - popNarray((char *)x, (unsigned int)(n*4)) ; -} -void lookreal4array(float *x, int n) { - lookNarray((char *)x, (unsigned int)(n*4)) ; +void endstackrepeat_() { + endStackRepeat() ; } -void pushreal8array(double *x, int n) { - pushNarray((char *)x,(unsigned int)(n*8)) ; -} -void popreal8array(double *x, int n) { - popNarray((char *)x,(unsigned int)(n*8)) ; -} -void lookreal8array(double *x, int n) { - lookNarray((char *)x,(unsigned int)(n*8)) ; +void pushnarray_(char *x, unsigned int *nbChars, int *checkReadOnly) { + pushNArray(x, *nbChars, *checkReadOnly) ; } -void pushreal16array(void *x, int n) { - pushNarray((char *)x,(unsigned int)(n*16)) ; -} -void popreal16array(void *x, int n) { - popNarray((char *)x,(unsigned int)(n*16)) ; -} -void lookreal16array(void *x, int n) { - lookNarray((char *)x,(unsigned int)(n*16)) ; +void popnarray_(char *x, unsigned int *nbChars, int *checkReadOnly) { + popNArray(x, *nbChars, *checkReadOnly) ; } -void pushreal32array(void *x, int n) { - pushNarray((char *)x,(unsigned int)(n*32)) ; -} -void popreal32array(void *x, int n) { - popNarray((char *)x,(unsigned int)(n*32)) ; -} -void lookreal32array(void *x, int n) { - lookNarray((char *)x,(unsigned int)(n*32)) ; +void pushinteger4array_(int *ii, int *ll) { + pushInteger4Array(ii, *ll) ; } -void pushcomplex4array(void *x, int n) { - pushNarray((char *)x,(unsigned int)(n*4)) ; -} -void popcomplex4array(void *x, int n) { - popNarray((char *)x,(unsigned int)(n*4)) ; -} -void lookcomplex4array(void *x, int n) { - lookNarray((char *)x,(unsigned int)(n*4)) ; +void popinteger4array_(int *ii, int *ll) { + popInteger4Array(ii, *ll) ; } -void pushcomplex8array(void *x, int n) { - pushNarray((char *)x,(unsigned int)(n*8)) ; -} -void popcomplex8array(void *x, int n) { - popNarray((char *)x,(unsigned int)(n*8)) ; -} -void lookcomplex8array(void *x, int n) { - lookNarray((char *)x,(unsigned int)(n*8)) ; +void pushinteger8array_(long *ii, int *ll) { + pushInteger8Array(ii, *ll) ; } -void pushcomplex16array(void *x, int n) { - pushNarray((char *)x,(unsigned int)(n*16)) ; -} -void popcomplex16array(void *x, int n) { - popNarray((char *)x,(unsigned int)(n*16)) ; -} -void lookcomplex16array(void *x, int n) { - lookNarray((char *)x,(unsigned int)(n*16)) ; +void popinteger8array_(long *ii, int *ll) { + popInteger8Array(ii, *ll) ; } -void pushcomplex32array(void *x, int n) { - pushNarray((char *)x,(unsigned int)(n*32)) ; -} -void popcomplex32array(void *x, int n) { - popNarray((char *)x,(unsigned int)(n*32)) ; -} -void lookcomplex32array(void *x, int n) { - lookNarray((char *)x,(unsigned int)(n*32)) ; +void pushreal4array_(float *ii, int *ll) { + pushReal4Array(ii, *ll) ; } -void pushpointer4array(void *x, int n) { - pushNarray((char *)x, (unsigned int)(n*4)) ; -} -void poppointer4array(void *x, int n) { - popNarray((char *)x, (unsigned int)(n*4)) ; -} -void lookpointer4array(void *x, int n) { - lookNarray((char *)x, (unsigned int)(n*4)) ; +void popreal4array_(float *ii, int *ll) { + popReal4Array(ii, *ll) ; } -void pushpointer8array(void *x, int n) { - pushNarray((char *)x,(unsigned int)(n*8)) ; -} -void poppointer8array(void *x, int n) { - popNarray((char *)x,(unsigned int)(n*8)) ; -} -void lookpointer8array(void *x, int n) { - lookNarray((char *)x,(unsigned int)(n*8)) ; +void pushreal8array_(double *ii, int *ll) { + pushReal8Array(ii, *ll) ; } -/************* Debug displays of the state of the stack: ***********/ - -void printbigbytes(long int nbblocks, long int blocksz, long int nbunits) { - long int a3, b3, res3, res6, res9, res12 ; - int a0, b0, res0 ; - int printzeros = 0 ; - a0 = (int)nbblocks%1000 ; - a3 = nbblocks/1000 ; - b0 = (int)blocksz%1000 ; - b3 = blocksz/1000 ; - res0 = ((int)(nbunits%1000)) + a0*b0 ; - res3 = nbunits/1000 + a3*b0 + a0*b3 ; - res6 = a3*b3 ; - res3 += ((long int)(res0/1000)) ; - res0 = res0%1000 ; - res6 += res3/1000 ; - res3 = res3%1000 ; - res9 = res6/1000 ; - res6 = res6%1000 ; - res12 = res9/1000 ; - res9 = res9%1000 ; - if (res12>0) { - printf("%li ", res12) ; - printzeros = 1 ; - } - if ((res9/100)>0 || printzeros) { - printf("%li",res9/100) ; - printzeros = 1 ; - res9 = res9%100 ; - } - if ((res9/10)>0 || printzeros) { - printf("%li",res9/10) ; - printzeros = 1 ; - res9 = res9%10 ; - } - if (res9>0 || printzeros) { - printf("%li ",res9) ; - printzeros = 1 ; - } - if ((res6/100)>0 || printzeros) { - printf("%li",res6/100) ; - printzeros = 1 ; - res6 = res6%100 ; - } - if ((res6/10)>0 || printzeros) { - printf("%li",res6/10) ; - printzeros = 1 ; - res6 = res6%10 ; - } - if (res6>0 || printzeros) { - printf("%li ",res6) ; - printzeros = 1 ; - } - if ((res3/100)>0 || printzeros) { - printf("%li",res3/100) ; - printzeros = 1 ; - res3 = res3%100 ; - } - if ((res3/10)>0 || printzeros) { - printf("%li",res3/10) ; - printzeros = 1 ; - res3 = res3%10 ; - } - if (res3>0 || printzeros) { - printf("%li ",res3) ; - printzeros = 1 ; - } - if ((res0/100)>0 || printzeros) { - printf("%i",res0/100) ; - printzeros = 1 ; - res0 = res0%100 ; - } - if ((res0/10)>0 || printzeros) { - printf("%i",res0/10) ; - printzeros = 1 ; - res0 = res0%10 ; - } - printf("%i",res0) ; +void popreal8array_(double *ii, int *ll) { + popReal8Array(ii, *ll) ; } -void printctraffic_() { - printf(" C Traffic: ") ; - printbigbytes(mmctrafficM, 1000000, mmctraffic) ; - printf(" bytes\n") ; +void pushcomplex8array_(ccmplx *ii, int *ll) { + pushComplex8Array(ii, *ll) ; } -void printftrafficinc_(long int *mmfM, int *mmfsz, int *mmf) { - printf(" F Traffic: ") ; - printbigbytes(*mmfM, (long int)*mmfsz, (long int)*mmf) ; - printf(" bytes\n") ; +void popcomplex8array_(ccmplx *ii, int *ll) { + popComplex8Array(ii, *ll) ; } -void printtotaltraffic_(long int *mmfM, int *mmfsz, int *mmf) { - printf(" C+F Traffic: ") ; - printbigbytes(mmctrafficM, 1000000, mmctraffic) ; - printf(" + "); - printbigbytes(*mmfM, (long int)*mmfsz, (long int)*mmf) ; - printf(" bytes\n") ; +void pushcomplex16array_(cdcmplx *ii, int *ll) { + pushComplex16Array(ii, *ll) ; } -void printtopplace_() { - DoubleChainedBlock *stack = curStack ; - int nbBlocks = (stack?-1:0) ; - int remainder = 0; - while(stack) { - stack = stack->prev ; - nbBlocks++ ; - } - if (curStack && curStackTop) remainder = curStackTop-(curStack->contents) ; - printf(" Stack size: ") ; - printbigbytes((long int)nbBlocks, ONE_BLOCK_SIZE, (long int)remainder) ; - printf(" bytes\n") ; -} - -void printtopplacenum_(int *n) { - DoubleChainedBlock *stack = curStack ; - int nbBlocks = (stack?-1:0) ; - int remainder = 0; - while(stack) { - stack = stack->prev ; - nbBlocks++ ; - } - if (curStack && curStackTop) remainder = curStackTop-(curStack->contents) ; - printf(" Stack size at location %i : ", *n) ; - printbigbytes((long int)nbBlocks, ONE_BLOCK_SIZE, (long int)remainder) ; - printf(" bytes\n") ; -} - -void printstackmax_() { - DoubleChainedBlock *stack = curStack ; - int nbBlocks = (stack?-2:0) ; - int remainder = 0; - long int totalsz ; - while(stack) { - stack = stack->prev ; - nbBlocks++ ; - } - stack = curStack ; - while(stack) { - stack = stack->next ; - nbBlocks++ ; - } - - printf(" Max Stack size (%i blocks): ", nbBlocks) ; - printbigbytes((long int)nbBlocks, ONE_BLOCK_SIZE, (long int)0) ; - printf(" bytes\n") ; -} - -void printlookingplace_() { - if (lookStack == NULL) - printtopplace_() ; - else { - DoubleChainedBlock *stack = lookStack ; - int nbBlocks = (stack?-1:0) ; - while(stack) { - stack = stack->prev ; - nbBlocks++ ; - } - printf(" Stack look at: ") ; - printbigbytes((long int)nbBlocks, ONE_BLOCK_SIZE, - ((long int)(lookStackTop-(lookStack->contents)))) ; - printf(" bytes\n") ; - } +void popcomplex16array_(cdcmplx *ii, int *ll) { + popComplex16Array(ii, *ll) ; } -void showrecentcstack_() { - if (curStack && curStackTop) { - int totalNumChars = 60 ; - DoubleChainedBlock *stack = curStack ; - char *stackTop = curStackTop ; - unsigned short int *st1 ; - printf("TOP OF C STACK : ") ; - while (totalNumChars>0 && stackTop>(stack->contents)) { - stackTop-- ; -/* ATTENTION!! en 64 bits, unsigned short int fait 2 octets, donc ce print est un peu faux */ - st1 = (unsigned short int *)stackTop ; - printf("%02X,",*st1%256) ; - totalNumChars-- ; - } - while (totalNumChars>0 && stack->prev) { - printf(" || ") ; - stack = stack->prev ; - stackTop = (stack->contents)+ONE_BLOCK_SIZE ; - while (totalNumChars>0 && stackTop>(stack->contents)) { - stackTop-- ; - st1 = (unsigned short int *)stackTop ; - printf("%02X,",*st1%256) ; - totalNumChars-- ; - } - } - if (stack->prev || stackTop>(stack->contents)) - printf(" ...\n") ; - else - printf(" || BOTTOM\n") ; - } else { - printf("NOTHING IN C STACK.\n") ; - } +void pushcharacterarray_(char *ii, int *ll) { + pushCharacterArray(ii, *ll) ; } -void getnbblocksinstack_(int *nbblocks) { - DoubleChainedBlock *stack = curStack ; - *nbblocks = 0 ; - while(stack) { - stack = stack->prev ; - (*nbblocks)++ ; - } +void popcharacterarray_(char *ii, int *ll) { + popCharacterArray(ii, *ll) ; } -/* Computes (and returns into its args) the number of blocks below the current - * stack top (resp. look) position, and the number of bytes below - * the current top (resp. look) position in the topmost block of the current - * top (resp. look) position. */ -void getbigcsizes_(int *nbblocks, int *remainder, int *nbblockslook, int *lookremainder) { - DoubleChainedBlock *stack ; - - stack = curStack ; - *nbblocks = (stack?-1:0) ; - while(stack) { - stack = stack->prev ; - (*nbblocks)++ ; - } - if (curStack && curStackTop) - *remainder = curStackTop-(curStack->contents) ; - else - *remainder = 0 ; +void pushbooleanarray_(char *x, unsigned int *n) { + pushNArray(x,(*n*4), 1) ; +} - if (lookStack == NULL) { - *nbblockslook = -999 ; - *lookremainder = -999 ; - } else { - stack = lookStack ; - *nbblockslook = (stack?-1:0) ; - while(stack) { - stack = stack->prev ; - (*nbblockslook)++ ; - } - *lookremainder = lookStackTop-(lookStack->contents) ; - } +void popbooleanarray_(char *x, unsigned int *n) { + popNArray(x,(*n*4), 1) ; } diff --git a/src/adjoint/adtprojections_b.f90 b/src/adjoint/adtProjections_b.f90 similarity index 83% rename from src/adjoint/adtprojections_b.f90 rename to src/adjoint/adtProjections_b.f90 index 2d12150..e8a306a 100644 --- a/src/adjoint/adtprojections_b.f90 +++ b/src/adjoint/adtProjections_b.f90 @@ -1,5 +1,5 @@ -! Generated by TAPENADE (INRIA, Tropics team) -! Tapenade 3.10 (r5363) - 9 Sep 2014 09:53 +! Generated by TAPENADE (INRIA, Ecuador team) +! Tapenade 3.16 (master) - 9 Oct 2020 17:47 ! ! ! ****************************************************************** @@ -58,21 +58,19 @@ SUBROUTINE TRIAPROJECTION_B(x1, x1b, x2, x2b, x3, x3b, x, xb, xf, xfb& INTRINSIC ABS INTRINSIC SIGN INTRINSIC MIN - INTEGER :: branch - REAL(kind=realtype) :: y1b - REAL(kind=realtype) :: y4b - REAL(kind=realtype) :: max2b - REAL(kind=realtype) :: tempb1 - REAL(kind=realtype) :: tempb0 - REAL(kind=realtype) :: y3b + REAL(kind=realtype) :: max1 REAL(kind=realtype) :: max1b + REAL(kind=realtype) :: max2 + REAL(kind=realtype) :: max2b + REAL(kind=realtype) :: max3 + REAL(kind=realtype) :: max3b + REAL(kind=realtype) :: y1b REAL(kind=realtype) :: tempb REAL(kind=realtype) :: y2b + REAL(kind=realtype) :: y3b + REAL(kind=realtype) :: y4b REAL(kind=realtype) :: y5b - REAL(kind=realtype) :: max3b - REAL(kind=realtype) :: max3 - REAL(kind=realtype) :: max2 - REAL(kind=realtype) :: max1 + INTEGER :: branch REAL(kind=realtype) :: y5 REAL(kind=realtype) :: y4 REAL(kind=realtype) :: y3 @@ -98,11 +96,11 @@ SUBROUTINE TRIAPROJECTION_B(x1, x1b, x2, x2b, x3, x3b, x, xb, xf, xfb& CALL PUSHCONTROL1B(1) END IF invlen = one/max1 - CALL PUSHREAL4ARRAY(norm(1), realtype/4) + CALL PUSHREAL8(norm(1)) norm(1) = norm(1)*invlen - CALL PUSHREAL4ARRAY(norm(2), realtype/4) + CALL PUSHREAL8(norm(2)) norm(2) = norm(2)*invlen - CALL PUSHREAL4ARRAY(norm(3), realtype/4) + CALL PUSHREAL8(norm(3)) norm(3) = norm(3)*invlen ! Determine the vector vf from xf to given coordinate. vf(1) = x(1) - x1(1) @@ -149,10 +147,10 @@ SUBROUTINE TRIAPROJECTION_B(x1, x1b, x2, x2b, x3, x3b, x, xb, xf, xfb& max2 = eps CALL PUSHCONTROL1B(1) END IF - CALL PUSHREAL4ARRAY(vn, realtype/4) + CALL PUSHREAL8(vn) vn = SIGN(max2, vn) u = (vt(1)*bn(1)+vt(2)*bn(2)+vt(3)*bn(3))/vn - CALL PUSHREAL4ARRAY(vn, realtype/4) + CALL PUSHREAL8(vn) vn = b(1)*an(1) + b(2)*an(2) + b(3)*an(3) IF (vn .GE. 0.) THEN y3 = vn @@ -168,15 +166,15 @@ SUBROUTINE TRIAPROJECTION_B(x1, x1b, x2, x2b, x3, x3b, x, xb, xf, xfb& max3 = eps CALL PUSHCONTROL1B(1) END IF - CALL PUSHREAL4ARRAY(vn, realtype/4) + CALL PUSHREAL8(vn) vn = SIGN(max3, vn) v = (vt(1)*an(1)+vt(2)*an(2)+vt(3)*an(3))/vn ! Triangles should be bounded by the line u + v = 1 uv = u + v IF (uv .GT. one) THEN - CALL PUSHREAL4ARRAY(u, realtype/4) + CALL PUSHREAL8(u) u = u/uv - CALL PUSHREAL4ARRAY(v, realtype/4) + CALL PUSHREAL8(v) v = v/uv CALL PUSHCONTROL1B(0) ELSE @@ -210,9 +208,9 @@ SUBROUTINE TRIAPROJECTION_B(x1, x1b, x2, x2b, x3, x3b, x, xb, xf, xfb& v = one CALL PUSHCONTROL1B(1) END IF - x1b = 0.0 - ab = 0.0 - bb = 0.0 + x1b = 0.0_8 + ab = 0.0_8 + bb = 0.0_8 x1b = xfb ub = ub + SUM(a*xfb) ab = u*xfb @@ -222,55 +220,55 @@ SUBROUTINE TRIAPROJECTION_B(x1, x1b, x2, x2b, x3, x3b, x, xb, xf, xfb& IF (branch .EQ. 0) THEN y5b = vb ELSE - y5b = 0.0 + y5b = 0.0_8 END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN vb = y5b ELSE - vb = 0.0 + vb = 0.0_8 END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN y4b = ub ELSE - y4b = 0.0 + y4b = 0.0_8 END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN ub = y4b ELSE - ub = 0.0 + ub = 0.0_8 END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN - CALL POPREAL4ARRAY(v, realtype/4) - CALL POPREAL4ARRAY(u, realtype/4) - uvb = -(u*ub/uv**2) - v*vb/uv**2 + CALL POPREAL8(v) + CALL POPREAL8(u) + uvb = -(v*vb/uv**2) - u*ub/uv**2 vb = vb/uv ub = ub/uv ELSE - uvb = 0.0 + uvb = 0.0_8 END IF ub = ub + uvb vb = vb + uvb - anb = 0.0 - vtb = 0.0 - tempb1 = vb/vn - vtb(1) = vtb(1) + an(1)*tempb1 - anb(1) = anb(1) + vt(1)*tempb1 - vtb(2) = vtb(2) + an(2)*tempb1 - anb(2) = anb(2) + vt(2)*tempb1 - vtb(3) = vtb(3) + an(3)*tempb1 - anb(3) = anb(3) + vt(3)*tempb1 - vnb = -((vt(1)*an(1)+vt(2)*an(2)+vt(3)*an(3))*tempb1/vn) - CALL POPREAL4ARRAY(vn, realtype/4) + anb = 0.0_8 + vtb = 0.0_8 + tempb = vb/vn + vtb(1) = vtb(1) + an(1)*tempb + anb(1) = anb(1) + vt(1)*tempb + vtb(2) = vtb(2) + an(2)*tempb + anb(2) = anb(2) + vt(2)*tempb + vtb(3) = vtb(3) + an(3)*tempb + anb(3) = anb(3) + vt(3)*tempb + vnb = -((vt(1)*an(1)+vt(2)*an(2)+vt(3)*an(3))*tempb/vn) + CALL POPREAL8(vn) max3b = SIGN(1.d0, max3*vn)*vnb CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN y3b = max3b ELSE - y3b = 0.0 + y3b = 0.0_8 END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN @@ -278,29 +276,29 @@ SUBROUTINE TRIAPROJECTION_B(x1, x1b, x2, x2b, x3, x3b, x, xb, xf, xfb& ELSE vnb = -y3b END IF - CALL POPREAL4ARRAY(vn, realtype/4) + CALL POPREAL8(vn) bb(1) = bb(1) + an(1)*vnb anb(1) = anb(1) + b(1)*vnb bb(2) = bb(2) + an(2)*vnb anb(2) = anb(2) + b(2)*vnb bb(3) = bb(3) + an(3)*vnb anb(3) = anb(3) + b(3)*vnb - bnb = 0.0 - tempb0 = ub/vn - vtb(1) = vtb(1) + bn(1)*tempb0 - bnb(1) = bnb(1) + vt(1)*tempb0 - vtb(2) = vtb(2) + bn(2)*tempb0 - bnb(2) = bnb(2) + vt(2)*tempb0 - vtb(3) = vtb(3) + bn(3)*tempb0 - bnb(3) = bnb(3) + vt(3)*tempb0 - vnb = -((vt(1)*bn(1)+vt(2)*bn(2)+vt(3)*bn(3))*tempb0/vn) - CALL POPREAL4ARRAY(vn, realtype/4) + bnb = 0.0_8 + tempb = ub/vn + vtb(1) = vtb(1) + bn(1)*tempb + bnb(1) = bnb(1) + vt(1)*tempb + vtb(2) = vtb(2) + bn(2)*tempb + bnb(2) = bnb(2) + vt(2)*tempb + vtb(3) = vtb(3) + bn(3)*tempb + bnb(3) = bnb(3) + vt(3)*tempb + vnb = -((vt(1)*bn(1)+vt(2)*bn(2)+vt(3)*bn(3))*tempb/vn) + CALL POPREAL8(vn) max2b = SIGN(1.d0, max2*vn)*vnb CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN y2b = max2b ELSE - y2b = 0.0 + y2b = 0.0_8 END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN @@ -308,113 +306,83 @@ SUBROUTINE TRIAPROJECTION_B(x1, x1b, x2, x2b, x3, x3b, x, xb, xf, xfb& ELSE vnb = -y2b END IF - ab(1) = ab(1) + bn(1)*vnb + ab(1) = ab(1) + bn(1)*vnb + norm(2)*anb(3) - norm(3)*anb(2) bnb(1) = bnb(1) + a(1)*vnb - ab(2) = ab(2) + bn(2)*vnb + ab(2) = ab(2) + bn(2)*vnb + norm(3)*anb(1) - norm(1)*anb(3) bnb(2) = bnb(2) + a(2)*vnb - ab(3) = ab(3) + bn(3)*vnb + ab(3) = ab(3) + bn(3)*vnb + norm(1)*anb(2) - norm(2)*anb(1) bnb(3) = bnb(3) + a(3)*vnb - normb = 0.0 - bb(1) = bb(1) + norm(2)*bnb(3) - normb(2) = normb(2) + b(1)*bnb(3) - bb(2) = bb(2) - norm(1)*bnb(3) - normb(1) = normb(1) - b(2)*bnb(3) - bnb(3) = 0.0 - bb(3) = bb(3) + norm(1)*bnb(2) - normb(1) = normb(1) + b(3)*bnb(2) - bb(1) = bb(1) - norm(3)*bnb(2) - normb(3) = normb(3) - b(1)*bnb(2) - bnb(2) = 0.0 - bb(2) = bb(2) + norm(3)*bnb(1) - normb(3) = normb(3) + b(2)*bnb(1) - bb(3) = bb(3) - norm(2)*bnb(1) - normb(2) = normb(2) + a(1)*anb(3) - b(3)*bnb(1) - ab(1) = ab(1) + norm(2)*anb(3) - ab(2) = ab(2) - norm(1)*anb(3) - normb(1) = normb(1) - a(2)*anb(3) - anb(3) = 0.0 - ab(3) = ab(3) + norm(1)*anb(2) - normb(1) = normb(1) + a(3)*anb(2) - ab(1) = ab(1) - norm(3)*anb(2) - normb(3) = normb(3) - a(1)*anb(2) - anb(2) = 0.0 - ab(2) = ab(2) + norm(3)*anb(1) - normb(3) = normb(3) + a(2)*anb(1) - ab(3) = ab(3) - norm(2)*anb(1) - normb(2) = normb(2) - a(3)*anb(1) + normb = 0.0_8 + bb(1) = bb(1) + norm(2)*bnb(3) - norm(3)*bnb(2) + bb(2) = bb(2) + norm(3)*bnb(1) - norm(1)*bnb(3) + bb(3) = bb(3) + norm(1)*bnb(2) - norm(2)*bnb(1) vn = vf(1)*norm(1) + vf(2)*norm(2) + vf(3)*norm(3) - vfb = 0.0 - vfb(3) = vfb(3) + vtb(3) - vnb = -(norm(3)*vtb(3)) - normb(3) = normb(3) - vn*vtb(3) - vtb(3) = 0.0 - vfb(2) = vfb(2) + vtb(2) - vnb = vnb - norm(2)*vtb(2) - normb(2) = normb(2) - vn*vtb(2) - vtb(2) = 0.0 - vnb = vnb - norm(1)*vtb(1) - vfb(1) = vfb(1) + norm(1)*vnb + vtb(1) - normb(1) = normb(1) + vf(1)*vnb - vn*vtb(1) - vfb(2) = vfb(2) + norm(2)*vnb - normb(2) = normb(2) + vf(2)*vnb - vfb(3) = vfb(3) + norm(3)*vnb - normb(3) = normb(3) + vf(3)*vnb - xb = 0.0 + vfb = 0.0_8 + vnb = -(norm(3)*vtb(3)) - norm(2)*vtb(2) - norm(1)*vtb(1) + normb(2) = normb(2) + b(1)*bnb(3) + a(1)*anb(3) - b(3)*bnb(1) + vf(2& +& )*vnb - a(3)*anb(1) - vn*vtb(2) + normb(1) = normb(1) + b(3)*bnb(2) - b(2)*bnb(3) + a(3)*anb(2) - a(2)& +& *anb(3) + vf(1)*vnb - vn*vtb(1) + bnb(3) = 0.0_8 + normb(3) = normb(3) + b(2)*bnb(1) - b(1)*bnb(2) + a(2)*anb(1) - a(1)& +& *anb(2) + vf(3)*vnb - vn*vtb(3) + bnb(2) = 0.0_8 + anb(3) = 0.0_8 + anb(2) = 0.0_8 + vfb(3) = vfb(3) + vtb(3) + norm(3)*vnb + vtb(3) = 0.0_8 + vfb(2) = vfb(2) + vtb(2) + norm(2)*vnb + vtb(2) = 0.0_8 + vfb(1) = vfb(1) + vtb(1) + norm(1)*vnb + xb = 0.0_8 xb(3) = xb(3) + vfb(3) x1b(3) = x1b(3) - vfb(3) - vfb(3) = 0.0 + vfb(3) = 0.0_8 xb(2) = xb(2) + vfb(2) x1b(2) = x1b(2) - vfb(2) - vfb(2) = 0.0 + vfb(2) = 0.0_8 xb(1) = xb(1) + vfb(1) x1b(1) = x1b(1) - vfb(1) - CALL POPREAL4ARRAY(norm(3), realtype/4) - invlenb = norm(3)*normb(3) + CALL POPREAL8(norm(3)) + CALL POPREAL8(norm(2)) + CALL POPREAL8(norm(1)) + invlenb = norm(3)*normb(3) + norm(2)*normb(2) + norm(1)*normb(1) normb(3) = invlen*normb(3) - CALL POPREAL4ARRAY(norm(2), realtype/4) - invlenb = invlenb + norm(2)*normb(2) normb(2) = invlen*normb(2) - CALL POPREAL4ARRAY(norm(1), realtype/4) - invlenb = invlenb + norm(1)*normb(1) normb(1) = invlen*normb(1) max1b = -(one*invlenb/max1**2) CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN y1b = max1b ELSE - y1b = 0.0 + y1b = 0.0_8 END IF IF (norm(1)**2 + norm(2)**2 + norm(3)**2 .EQ. 0.0) THEN - tempb = 0.0 + tempb = 0.0_8 ELSE tempb = y1b/(2.0*SQRT(norm(1)**2+norm(2)**2+norm(3)**2)) END IF normb(1) = normb(1) + 2*norm(1)*tempb normb(2) = normb(2) + 2*norm(2)*tempb normb(3) = normb(3) + 2*norm(3)*tempb - ab(1) = ab(1) + b(2)*normb(3) - bb(2) = bb(2) + a(1)*normb(3) - ab(2) = ab(2) - b(1)*normb(3) - bb(1) = bb(1) - a(2)*normb(3) - normb(3) = 0.0 - ab(3) = ab(3) + b(1)*normb(2) - bb(1) = bb(1) + a(3)*normb(2) - ab(1) = ab(1) - b(3)*normb(2) - bb(3) = bb(3) - a(1)*normb(2) - normb(2) = 0.0 - ab(2) = ab(2) + b(3)*normb(1) - bb(3) = bb(3) + a(2)*normb(1) - ab(3) = ab(3) - b(2)*normb(1) - bb(2) = bb(2) - a(3)*normb(1) - x3b = 0.0 + ab(1) = ab(1) + b(2)*normb(3) - b(3)*normb(2) + bb(2) = bb(2) + a(1)*normb(3) - a(3)*normb(1) + ab(2) = ab(2) + b(3)*normb(1) - b(1)*normb(3) + bb(1) = bb(1) + a(3)*normb(2) - a(2)*normb(3) + normb(3) = 0.0_8 + ab(3) = ab(3) + b(1)*normb(2) - b(2)*normb(1) + bb(3) = bb(3) + a(2)*normb(1) - a(1)*normb(2) + normb(2) = 0.0_8 + x3b = 0.0_8 x3b = bb - x1b = x1b - ab - bb - x2b = 0.0 + x1b = x1b - bb - ab + x2b = 0.0_8 x2b = ab - ub = 0.0 - vb = 0.0 - xfb = 0.0 + ub = 0.0_8 + vb = 0.0_8 + xfb = 0.0_8 END SUBROUTINE TRIAPROJECTION_B + !=============================================================== SUBROUTINE TRIAPROJECTION(x1, x2, x3, x, xf, u, v, val) IMPLICIT NONE @@ -434,9 +402,9 @@ SUBROUTINE TRIAPROJECTION(x1, x2, x3, x, xf, u, v, val) INTRINSIC ABS INTRINSIC SIGN INTRINSIC MIN - REAL(kind=realtype) :: max3 - REAL(kind=realtype) :: max2 REAL(kind=realtype) :: max1 + REAL(kind=realtype) :: max2 + REAL(kind=realtype) :: max3 REAL(kind=realtype) :: y5 REAL(kind=realtype) :: y4 REAL(kind=realtype) :: y3 @@ -554,6 +522,7 @@ SUBROUTINE TRIAPROJECTION(x1, x2, x3, x, xf, u, v, val) dz = x(3) - xf(3) val = dx*dx + dy*dy + dz*dz END SUBROUTINE TRIAPROJECTION + !*************************************************************** !*************************************************************** SUBROUTINE QUADPROJECTION(x1, x2, x3, x4, x, xf, u, v, val) @@ -577,8 +546,8 @@ SUBROUTINE QUADPROJECTION(x1, x2, x3, x4, x, xf, u, v, val) INTRINSIC MAX INTRINSIC MIN INTRINSIC SQRT - REAL(kind=realtype) :: y2 REAL(kind=realtype) :: y1 + REAL(kind=realtype) :: y2 ! EXECUTION ! Initialize u and v to 0.5 and determine the ! corresponding coordinates on the face, which is the @@ -638,6 +607,7 @@ SUBROUTINE QUADPROJECTION(x1, x2, x3, x4, x, xf, u, v, val) dz = x(3) - xf(3) val = dx*dx + dy*dy + dz*dz END SUBROUTINE QUADPROJECTION + ! Differentiation of quadprojresidual in reverse (adjoint) mode: ! gradient of useful results: residual ! with respect to varying inputs: u v x residual x1 x2 x3 x4 @@ -727,105 +697,98 @@ SUBROUTINE QUADPROJRESIDUAL_B(x1, x1b, x2, x2b, x3, x3b, x4, x4b, x, & ! The residual is the objective function gradient ! Now assemble the Jacobian of the function we are solving (Jac(grad(dist2))) ! Invert the Jacobian - graddist2b = 0.0 + graddist2b = 0.0_8 graddist2b = residualb - ab = 0.0 - graduvb = 0.0 + ab = 0.0_8 + graduvb = 0.0_8 CALL DOTPROD_B(a, ab, graduv(2, :), graduvb(2, :), graddist2(2), & & graddist2b(2)) - graddist2b(2) = 0.0 + graddist2b(2) = 0.0_8 CALL DOTPROD_B(a, ab, graduv(1, :), graduvb(1, :), graddist2(1), & & graddist2b(1)) - graddist2b(1) = 0.0 - ub = v*2.0*2*u*graduvb(2, 9) - vb = 2.0*u**2*graduvb(2, 9) - graduvb(2, 9) = 0.0 - ub = ub + 2.0*v*graduvb(2, 8) - vb = vb + 2.0*u*graduvb(2, 8) - graduvb(2, 8) = 0.0 - ub = ub + 2*u*graduvb(2, 7) - graduvb(2, 7) = 0.0 - vb = vb + 2.0*graduvb(2, 6) - graduvb(2, 6) = 0.0 - ub = ub + graduvb(2, 5) - graduvb(2, 5) = 0.0 - graduvb(2, 4) = 0.0 - graduvb(2, 3) = 0.0 - graduvb(2, 2) = 0.0 - graduvb(2, 1) = 0.0 - ub = ub + 2.0*v**2*graduvb(1, 9) - vb = vb + u*2.0*2*v*graduvb(1, 9) - graduvb(1, 9) = 0.0 - vb = vb + 2*v*graduvb(1, 8) - graduvb(1, 8) = 0.0 - ub = ub + 2.0*v*graduvb(1, 7) - vb = vb + 2.0*u*graduvb(1, 7) - graduvb(1, 7) = 0.0 - graduvb(1, 6) = 0.0 - vb = vb + graduvb(1, 5) - graduvb(1, 5) = 0.0 - ub = ub + 2.0*graduvb(1, 4) + graddist2b(1) = 0.0_8 + ub = 2*u*v*2.0*graduvb(2, 9) + v*2.0*graduvb(2, 8) + 2*u*graduvb(2, & +& 7) + graduvb(2, 5) + v**2*2.0*graduvb(1, 9) + v*2.0*graduvb(1, 7) & +& + 2.0*graduvb(1, 4) + vb = u**2*2.0*graduvb(2, 9) + u*2.0*graduvb(2, 8) + 2.0*graduvb(2, 6& +& ) + 2*v*u*2.0*graduvb(1, 9) + 2*v*graduvb(1, 8) + u*2.0*graduvb(1& +& , 7) + graduvb(1, 5) + graduvb(2, 9) = 0.0_8 + graduvb(2, 8) = 0.0_8 + graduvb(2, 7) = 0.0_8 + graduvb(2, 6) = 0.0_8 + graduvb(2, 5) = 0.0_8 + graduvb(2, 4) = 0.0_8 + graduvb(2, 3) = 0.0_8 + graduvb(2, 2) = 0.0_8 + graduvb(2, 1) = 0.0_8 + graduvb(1, 9) = 0.0_8 + graduvb(1, 8) = 0.0_8 + graduvb(1, 7) = 0.0_8 + graduvb(1, 6) = 0.0_8 + graduvb(1, 5) = 0.0_8 dotresultb = ab(9) - ab(9) = 0.0 - x3142b = 0.0 - dummyvecb = 0.0 + ab(9) = 0.0_8 + x3142b = 0.0_8 + dummyvecb = 0.0_8 CALL DOTPROD_B(x3142, x3142b, dummyvec, dummyvecb, dotresult, & & dotresultb) x3142b = x3142b + dummyvecb dotresultb = 2*ab(8) - ab(8) = 0.0 - x41b = 0.0 + ab(8) = 0.0_8 + x41b = 0.0_8 CALL DOTPROD_B(x41, x41b, x3142, x3142b, dotresult, dotresultb) dotresultb = 2*ab(7) - ab(7) = 0.0 - x21b = 0.0 + ab(7) = 0.0_8 + x21b = 0.0_8 CALL DOTPROD_B(x21, x21b, x3142, x3142b, dotresult, dotresultb) dotresultb = ab(6) - ab(6) = 0.0 + ab(6) = 0.0_8 dummyvec = x41 - dummyvecb = 0.0 + dummyvecb = 0.0_8 CALL DOTPROD_B(x41, x41b, dummyvec, dummyvecb, dotresult, dotresultb& & ) x41b = x41b + dummyvecb dotresultb = 2*ab(5) CALL DOTPROD_B(x21, x21b, x41, x41b, dotresult, dotresultb) dotresultb = 2*ab(5) - ab(5) = 0.0 - x10b = 0.0 + ab(5) = 0.0_8 + x10b = 0.0_8 CALL DOTPROD_B(x10, x10b, x3142, x3142b, dotresult, dotresultb) dotresultb = ab(4) - ab(4) = 0.0 + ab(4) = 0.0_8 dummyvec = x21 - dummyvecb = 0.0 + dummyvecb = 0.0_8 CALL DOTPROD_B(x21, x21b, dummyvec, dummyvecb, dotresult, dotresultb& & ) x21b = x21b + dummyvecb dotresultb = 2*ab(3) - ab(3) = 0.0 + ab(3) = 0.0_8 CALL DOTPROD_B(x10, x10b, x41, x41b, dotresult, dotresultb) dotresultb = 2*ab(2) - ab(2) = 0.0 + ab(2) = 0.0_8 CALL DOTPROD_B(x10, x10b, x21, x21b, dotresult, dotresultb) dotresultb = ab(1) dummyvec = x10 - dummyvecb = 0.0 + dummyvecb = 0.0_8 CALL DOTPROD_B(x10, x10b, dummyvec, dummyvecb, dotresult, dotresultb& & ) x10b = x10b + dummyvecb - x1b = 0.0 - x3b = 0.0 + x1b = 0.0_8 + x3b = 0.0_8 x3b = x3142b x21b = x21b - x3142b x41b = x41b - x3142b - x1b = x10b - x41b - x21b - x3142b - x4b = 0.0 + x1b = x10b - x3142b - x41b - x21b + x4b = 0.0_8 x4b = x41b - x2b = 0.0 + x2b = 0.0_8 x2b = x21b - xb = 0.0 + xb = 0.0_8 xb = -x10b - residualb = 0.0 + residualb = 0.0_8 END SUBROUTINE QUADPROJRESIDUAL_B + SUBROUTINE QUADPROJRESIDUAL(x1, x2, x3, x4, x, u, v, residual, invjac) IMPLICIT NONE ! DECLARATIONS @@ -908,6 +871,7 @@ SUBROUTINE QUADPROJRESIDUAL(x1, x2, x3, x4, x, u, v, residual, invjac) ! Invert the Jacobian CALL INVERT2X2(jac, invjac) END SUBROUTINE QUADPROJRESIDUAL + ! Differentiation of quadprojoutput in reverse (adjoint) mode: ! gradient of useful results: xf ! with respect to varying inputs: u v xf x1 x2 x3 x4 @@ -929,30 +893,33 @@ SUBROUTINE QUADPROJOUTPUT_B(x1, x1b, x2, x2b, x3, x3b, x4, x4b, u, ub& ! Working variables REAL(kind=realtype), DIMENSION(3) :: x21, x41, x3142 REAL(kind=realtype), DIMENSION(3) :: x21b, x41b, x3142b + REAL(kind=realtype) :: tempb ! EXECUTION ! Determine auxiliary vectors x21 = x2 - x1 x41 = x4 - x1 x3142 = x3 - x1 - x21 - x41 ! Compute guess for projection point - x1b = 0.0 - x3142b = 0.0 - x21b = 0.0 - x41b = 0.0 - ub = v*SUM(x3142*xfb) + SUM(x21*xfb) - vb = u*SUM(x3142*xfb) + SUM(x41*xfb) + tempb = SUM(x3142*xfb) + x1b = 0.0_8 + x3142b = 0.0_8 + x21b = 0.0_8 + x41b = 0.0_8 + ub = SUM(x21*xfb) + v*tempb + vb = SUM(x41*xfb) + u*tempb x3142b = u*v*xfb x21b = u*xfb - x3142b x41b = v*xfb - x3142b - x1b = xfb - x21b - x41b - x3142b - x3b = 0.0 + x1b = xfb - x3142b - x41b - x21b + x3b = 0.0_8 x3b = x3142b - x4b = 0.0 + x4b = 0.0_8 x4b = x41b - x2b = 0.0 + x2b = 0.0_8 x2b = x21b - xfb = 0.0 + xfb = 0.0_8 END SUBROUTINE QUADPROJOUTPUT_B + !=============================================================== SUBROUTINE QUADPROJOUTPUT(x1, x2, x3, x4, u, v, xf) IMPLICIT NONE @@ -972,6 +939,7 @@ SUBROUTINE QUADPROJOUTPUT(x1, x2, x3, x4, u, v, xf) ! Compute guess for projection point xf = x1 + u*x21 + v*x41 + u*v*x3142 END SUBROUTINE QUADPROJOUTPUT + ! Differentiation of triaweights in reverse (adjoint) mode: ! gradient of useful results: u v weight ! with respect to varying inputs: u v weight @@ -994,14 +962,13 @@ SUBROUTINE TRIAWEIGHTS_B(u, ub, v, vb, weight, weightb) ! EXECUTION ! Initialize weight vector ! Update values according to the current element type - vb = vb + weightb(3) - weightb(3) = 0.0 - ub = ub + weightb(2) - weightb(2) = 0.0 - ub = ub - weightb(1) - vb = vb - weightb(1) - weightb = 0.0 + vb = vb + weightb(3) - weightb(1) + weightb(3) = 0.0_8 + ub = ub + weightb(2) - weightb(1) + weightb(2) = 0.0_8 + weightb = 0.0_8 END SUBROUTINE TRIAWEIGHTS_B + !=============================================================== !=============================================================== !=============================================================== @@ -1023,6 +990,7 @@ SUBROUTINE TRIAWEIGHTS(u, v, weight) weight(2) = u weight(3) = v END SUBROUTINE TRIAWEIGHTS + ! Differentiation of quadweights in reverse (adjoint) mode: ! gradient of useful results: u v weight ! with respect to varying inputs: u v weight @@ -1042,19 +1010,16 @@ SUBROUTINE QUADWEIGHTS_B(u, ub, v, vb, weight, weightb) ! EXECUTION ! Initialize weight vector ! Update values according to the current element type - ub = ub - v*weightb(4) - vb = vb + (one-u)*weightb(4) - weightb(4) = 0.0 - ub = ub + v*weightb(3) - vb = vb + u*weightb(3) - weightb(3) = 0.0 - ub = ub + (one-v)*weightb(2) - vb = vb - u*weightb(2) - weightb(2) = 0.0 - ub = ub - (one-v)*weightb(1) - vb = vb - (one-u)*weightb(1) - weightb = 0.0 + ub = ub + v*weightb(3) - v*weightb(4) + (one-v)*weightb(2) - (one-v)& +& *weightb(1) + vb = vb + (one-u)*weightb(4) + u*weightb(3) - u*weightb(2) - (one-u)& +& *weightb(1) + weightb(4) = 0.0_8 + weightb(3) = 0.0_8 + weightb(2) = 0.0_8 + weightb = 0.0_8 END SUBROUTINE QUADWEIGHTS_B + !=============================================================== SUBROUTINE QUADWEIGHTS(u, v, weight) IMPLICIT NONE @@ -1074,6 +1039,7 @@ SUBROUTINE QUADWEIGHTS(u, v, weight) weight(3) = u*v weight(4) = (one-u)*v END SUBROUTINE QUADWEIGHTS + ! Differentiation of computenodalnormals in reverse (adjoint) mode: ! gradient of useful results: coor nodalnormals ! with respect to varying inputs: coor nodalnormals @@ -1109,8 +1075,6 @@ SUBROUTINE COMPUTENODALNORMALS_B(ncoor, ntria, nquads, coor, coorb, & REAL(kind=realtype) :: dotresult, dummyvec(3) REAL(kind=realtype) :: dotresultb, dummyvecb(3) INTRINSIC SQRT - REAL(kind=realtype) :: temp1 - REAL(kind=realtype) :: temp0 REAL(kind=realtype) :: temp !=============================================================== ! Initialize cumulative variables @@ -1132,11 +1096,11 @@ SUBROUTINE COMPUTENODALNORMALS_B(ncoor, ntria, nquads, coor, coorb, & ! Take the cross-product of these vectors to obtain the normal vector CALL CROSSPROD(x12, x23, normal1) ! Normalize this normal vector - CALL PUSHREAL4ARRAY(dummyvec, realtype*3/4) + CALL PUSHREAL8ARRAY(dummyvec, 3) dummyvec = normal1 - CALL PUSHREAL4ARRAY(dotresult, realtype/4) + CALL PUSHREAL8(dotresult) CALL DOTPROD(normal1, dummyvec, dotresult) - CALL PUSHREAL4ARRAY(normal1, realtype*3/4) + CALL PUSHREAL8ARRAY(normal1, 3) normal1 = normal1/SQRT(dotresult) ! Add the contribution of this normal to the nodalNormals array nodalnormals(:, ind1) = nodalnormals(:, ind1) + normal1 @@ -1168,11 +1132,11 @@ SUBROUTINE COMPUTENODALNORMALS_B(ncoor, ntria, nquads, coor, coorb, & ! Take the cross-product of these vectors to obtain the normal vectors ! Normalize these normal vectors CALL CROSSPROD(x13, x24, normal1) - CALL PUSHREAL4ARRAY(dummyvec, realtype*3/4) + CALL PUSHREAL8ARRAY(dummyvec, 3) dummyvec = normal1 - CALL PUSHREAL4ARRAY(dotresult, realtype/4) + CALL PUSHREAL8(dotresult) CALL DOTPROD(normal1, dummyvec, dotresult) - CALL PUSHREAL4ARRAY(normal1, realtype*3/4) + CALL PUSHREAL8ARRAY(normal1, 3) normal1 = normal1/SQRT(dotresult) ! Add the contribution of this normal to the nodalNormals array nodalnormals(:, ind1) = nodalnormals(:, ind1) + normal1 @@ -1194,57 +1158,56 @@ SUBROUTINE COMPUTENODALNORMALS_B(ncoor, ntria, nquads, coor, coorb, & END DO DO i=1,ncoor ! Normalize these new averaged nodal normals - CALL PUSHREAL4ARRAY(normal1, realtype*3/4) + CALL PUSHREAL8ARRAY(normal1, 3) normal1 = nodalnormals(:, i) - CALL PUSHREAL4ARRAY(dummyvec, realtype*3/4) + CALL PUSHREAL8ARRAY(dummyvec, 3) dummyvec = normal1 - CALL PUSHREAL4ARRAY(dotresult, realtype/4) + CALL PUSHREAL8(dotresult) CALL DOTPROD(normal1, dummyvec, dotresult) END DO DO i=ncoor,1,-1 - normal1b = 0.0 - temp1 = SQRT(dotresult) - normal1b = nodalnormalsb(:, i)/temp1 + normal1b = 0.0_8 + temp = SQRT(dotresult) + normal1b = nodalnormalsb(:, i)/temp IF (dotresult .EQ. 0.0) THEN - dotresultb = 0.0 + dotresultb = 0.0_8 ELSE - dotresultb = SUM(-(normal1*nodalnormalsb(:, i)/temp1))/(temp1**2& -& *2.0) + dotresultb = -(SUM(normal1*nodalnormalsb(:, i))/(2.0*temp**3)) END IF dummyvec = normal1 - CALL POPREAL4ARRAY(dotresult, realtype/4) - dummyvecb = 0.0 + CALL POPREAL8(dotresult) + dummyvecb = 0.0_8 CALL DOTPROD_B(normal1, normal1b, dummyvec, dummyvecb, dotresult, & & dotresultb) - CALL POPREAL4ARRAY(dummyvec, realtype*3/4) + CALL POPREAL8ARRAY(dummyvec, 3) normal1b = normal1b + dummyvecb nodalnormalsb(:, i) = normal1b - CALL POPREAL4ARRAY(normal1, realtype*3/4) + CALL POPREAL8ARRAY(normal1, 3) END DO DO i=3,1,-1 nodalnormalsb(i, :) = nodalnormalsb(i, :)/connect_count END DO - normal1b = 0.0 + normal1b = 0.0_8 DO i=nquads,1,-1 ind4 = quadsconn(4, i) ind3 = quadsconn(3, i) ind2 = quadsconn(2, i) ind1 = quadsconn(1, i) - normal1b = normal1b + nodalnormalsb(:, ind3) + nodalnormalsb(:, & -& ind1) + nodalnormalsb(:, ind2) + nodalnormalsb(:, ind4) - CALL POPREAL4ARRAY(normal1, realtype*3/4) - temp0 = SQRT(dotresult) + normal1b = normal1b + nodalnormalsb(:, ind4) + nodalnormalsb(:, & +& ind3) + nodalnormalsb(:, ind2) + nodalnormalsb(:, ind1) + CALL POPREAL8ARRAY(normal1, 3) + temp = SQRT(dotresult) IF (dotresult .EQ. 0.0) THEN - dotresultb = 0.0 + dotresultb = 0.0_8 ELSE - dotresultb = SUM(-(normal1*normal1b/temp0))/(temp0**2*2.0) + dotresultb = -(SUM(normal1*normal1b)/(2.0*temp**3)) END IF - normal1b = normal1b/temp0 - CALL POPREAL4ARRAY(dotresult, realtype/4) - dummyvecb = 0.0 + normal1b = normal1b/temp + CALL POPREAL8(dotresult) + dummyvecb = 0.0_8 CALL DOTPROD_B(normal1, normal1b, dummyvec, dummyvecb, dotresult, & & dotresultb) - CALL POPREAL4ARRAY(dummyvec, realtype*3/4) + CALL POPREAL8ARRAY(dummyvec, 3) normal1b = normal1b + dummyvecb x2 = coor(:, ind2) x4 = coor(:, ind4) @@ -1253,12 +1216,12 @@ SUBROUTINE COMPUTENODALNORMALS_B(ncoor, ntria, nquads, coor, coorb, & x3 = coor(:, ind3) x13 = x3 - x1 CALL CROSSPROD_B(x13, x13b, x24, x24b, normal1, normal1b) - x2b = 0.0 - x4b = 0.0 + x2b = 0.0_8 + x4b = 0.0_8 x4b = x24b x2b = -x24b - x1b = 0.0 - x3b = 0.0 + x1b = 0.0_8 + x3b = 0.0_8 x3b = x13b x1b = -x13b coorb(:, ind4) = coorb(:, ind4) + x4b @@ -1270,21 +1233,21 @@ SUBROUTINE COMPUTENODALNORMALS_B(ncoor, ntria, nquads, coor, coorb, & ind3 = triaconn(3, i) ind2 = triaconn(2, i) ind1 = triaconn(1, i) - normal1b = normal1b + nodalnormalsb(:, ind2) + nodalnormalsb(:, & -& ind1) + nodalnormalsb(:, ind3) - CALL POPREAL4ARRAY(normal1, realtype*3/4) + normal1b = normal1b + nodalnormalsb(:, ind3) + nodalnormalsb(:, & +& ind2) + nodalnormalsb(:, ind1) + CALL POPREAL8ARRAY(normal1, 3) temp = SQRT(dotresult) IF (dotresult .EQ. 0.0) THEN - dotresultb = 0.0 + dotresultb = 0.0_8 ELSE - dotresultb = SUM(-(normal1*normal1b/temp))/(temp**2*2.0) + dotresultb = -(SUM(normal1*normal1b)/(2.0*temp**3)) END IF normal1b = normal1b/temp - CALL POPREAL4ARRAY(dotresult, realtype/4) - dummyvecb = 0.0 + CALL POPREAL8(dotresult) + dummyvecb = 0.0_8 CALL DOTPROD_B(normal1, normal1b, dummyvec, dummyvecb, dotresult, & & dotresultb) - CALL POPREAL4ARRAY(dummyvec, realtype*3/4) + CALL POPREAL8ARRAY(dummyvec, 3) normal1b = normal1b + dummyvecb x2 = coor(:, ind2) x3 = coor(:, ind3) @@ -1292,18 +1255,19 @@ SUBROUTINE COMPUTENODALNORMALS_B(ncoor, ntria, nquads, coor, coorb, & x1 = coor(:, ind1) x12 = x1 - x2 CALL CROSSPROD_B(x12, x12b, x23, x23b, normal1, normal1b) - x2b = 0.0 - x3b = 0.0 + x2b = 0.0_8 + x3b = 0.0_8 x2b = x23b - x12b x3b = -x23b - x1b = 0.0 + x1b = 0.0_8 x1b = x12b coorb(:, ind3) = coorb(:, ind3) + x3b coorb(:, ind2) = coorb(:, ind2) + x2b coorb(:, ind1) = coorb(:, ind1) + x1b END DO - nodalnormalsb = 0.0 + nodalnormalsb = 0.0_8 END SUBROUTINE COMPUTENODALNORMALS_B + !=============================================================== !=============================================================== !=============================================================== @@ -1412,6 +1376,7 @@ SUBROUTINE COMPUTENODALNORMALS(ncoor, ntria, nquads, coor, triaconn, & nodalnormals(:, i) = normal1/SQRT(dotresult) END DO END SUBROUTINE COMPUTENODALNORMALS + ! Differentiation of crossprod in reverse (adjoint) mode: ! gradient of useful results: c ! with respect to varying inputs: a b c @@ -1424,24 +1389,19 @@ SUBROUTINE CROSSPROD_B(a, ab, b, bb, c, cb) REAL(kind=realtype) :: ab(3), bb(3) REAL(kind=realtype) :: c(3) REAL(kind=realtype) :: cb(3) - ab = 0.0 - bb = 0.0 - ab(1) = ab(1) + b(2)*cb(3) - bb(2) = bb(2) + a(1)*cb(3) - ab(2) = ab(2) - b(1)*cb(3) - bb(1) = bb(1) - a(2)*cb(3) - cb(3) = 0.0 - ab(3) = ab(3) + b(1)*cb(2) - bb(1) = bb(1) + a(3)*cb(2) - ab(1) = ab(1) - b(3)*cb(2) - bb(3) = bb(3) - a(1)*cb(2) - cb(2) = 0.0 - ab(2) = ab(2) + b(3)*cb(1) - bb(3) = bb(3) + a(2)*cb(1) - ab(3) = ab(3) - b(2)*cb(1) - bb(2) = bb(2) - a(3)*cb(1) - cb(1) = 0.0 + ab = 0.0_8 + bb = 0.0_8 + ab(1) = ab(1) + b(2)*cb(3) - b(3)*cb(2) + bb(2) = bb(2) + a(1)*cb(3) - a(3)*cb(1) + ab(2) = ab(2) + b(3)*cb(1) - b(1)*cb(3) + bb(1) = bb(1) + a(3)*cb(2) - a(2)*cb(3) + cb(3) = 0.0_8 + ab(3) = ab(3) + b(1)*cb(2) - b(2)*cb(1) + bb(3) = bb(3) + a(2)*cb(1) - a(1)*cb(2) + cb(2) = 0.0_8 + cb(1) = 0.0_8 END SUBROUTINE CROSSPROD_B + !=============================================================== !=============================================================== !=============================================================== @@ -1453,6 +1413,7 @@ SUBROUTINE CROSSPROD(a, b, c) c(2) = a(3)*b(1) - a(1)*b(3) c(3) = a(1)*b(2) - a(2)*b(1) END SUBROUTINE CROSSPROD + ! Differentiation of dotprod in reverse (adjoint) mode: ! gradient of useful results: a b c ! with respect to varying inputs: a b @@ -1473,6 +1434,7 @@ SUBROUTINE DOTPROD_B(a, ab, b, bb, c, cb) ab = ab + b*cb bb = bb + a*cb END SUBROUTINE DOTPROD_B + !=============================================================== SUBROUTINE DOTPROD(a, b, c) IMPLICIT NONE @@ -1487,6 +1449,7 @@ SUBROUTINE DOTPROD(a, b, c) ! EXECUTION c = SUM(a*b) END SUBROUTINE DOTPROD + !=============================================================== SUBROUTINE INVERT2X2(a, ainv) IMPLICIT NONE @@ -1506,4 +1469,6 @@ SUBROUTINE INVERT2X2(a, ainv) ainv(2, 1) = -(a(2, 1)*detinv) ainv(2, 2) = a(1, 1)*detinv END SUBROUTINE INVERT2X2 + END MODULE ADTPROJECTIONS_B + diff --git a/src/adjoint/adtprojections_d.f90 b/src/adjoint/adtProjections_d.f90 similarity index 91% rename from src/adjoint/adtprojections_d.f90 rename to src/adjoint/adtProjections_d.f90 index c9c794f..d3eec6e 100644 --- a/src/adjoint/adtprojections_d.f90 +++ b/src/adjoint/adtProjections_d.f90 @@ -1,5 +1,5 @@ -! Generated by TAPENADE (INRIA, Tropics team) -! Tapenade 3.10 (r5363) - 9 Sep 2014 09:53 +! Generated by TAPENADE (INRIA, Ecuador team) +! Tapenade 3.16 (master) - 9 Oct 2020 17:47 ! ! ! ****************************************************************** @@ -58,24 +58,25 @@ SUBROUTINE TRIAPROJECTION_D(x1, x1d, x2, x2d, x3, x3d, x, xd, xf, xfd& INTRINSIC ABS INTRINSIC SIGN INTRINSIC MIN + REAL(kind=realtype) :: max1 + REAL(kind=realtype) :: max1d + REAL(kind=realtype) :: max2 + REAL(kind=realtype) :: max2d + REAL(kind=realtype) :: max3 + REAL(kind=realtype) :: max3d REAL(kind=realtype) :: arg1 REAL(kind=realtype) :: arg1d - REAL(kind=realtype) :: y4d - REAL(kind=realtype) :: max2d - REAL(kind=realtype) :: y3d - REAL(kind=realtype) :: max1d + REAL(kind=realtype) :: y1d + REAL(kind=realtype) :: temp REAL(kind=realtype) :: y2d + REAL(kind=realtype) :: y3d + REAL(kind=realtype) :: y4d REAL(kind=realtype) :: y5d - REAL(kind=realtype) :: max3d - REAL(kind=realtype) :: max3 - REAL(kind=realtype) :: max2 - REAL(kind=realtype) :: max1 REAL(kind=realtype) :: y5 REAL(kind=realtype) :: y4 REAL(kind=realtype) :: y3 REAL(kind=realtype) :: y2 REAL(kind=realtype) :: y1 - REAL(kind=realtype) :: y1d ! EXECUTION ! Determine the tangent vectors in u- and v-direction. ! Store these in a and b respectively. @@ -86,39 +87,39 @@ SUBROUTINE TRIAPROJECTION_D(x1, x1d, x2, x2d, x3, x3d, x, xd, xf, xfd& ! Determine the normal vector of the face by taking the ! cross product of a and b. Afterwards this vector will ! be scaled to a unit vector. - normd = 0.0 - normd(1) = ad(2)*b(3) + a(2)*bd(3) - ad(3)*b(2) - a(3)*bd(2) + normd = 0.0_8 + normd(1) = b(3)*ad(2) + a(2)*bd(3) - b(2)*ad(3) - a(3)*bd(2) norm(1) = a(2)*b(3) - a(3)*b(2) - normd(2) = ad(3)*b(1) + a(3)*bd(1) - ad(1)*b(3) - a(1)*bd(3) + normd(2) = b(1)*ad(3) + a(3)*bd(1) - b(3)*ad(1) - a(1)*bd(3) norm(2) = a(3)*b(1) - a(1)*b(3) - normd(3) = ad(1)*b(2) + a(1)*bd(2) - ad(2)*b(1) - a(2)*bd(1) + normd(3) = b(2)*ad(1) + a(1)*bd(2) - b(1)*ad(2) - a(2)*bd(1) norm(3) = a(1)*b(2) - a(2)*b(1) - arg1d = normd(1)*norm(1) + norm(1)*normd(1) + normd(2)*norm(2) + & -& norm(2)*normd(2) + normd(3)*norm(3) + norm(3)*normd(3) + arg1d = 2*norm(1)*normd(1) + 2*norm(2)*normd(2) + 2*norm(3)*normd(3) arg1 = norm(1)*norm(1) + norm(2)*norm(2) + norm(3)*norm(3) + temp = SQRT(arg1) IF (arg1 .EQ. 0.0) THEN - y1d = 0.0 + y1d = 0.0_8 ELSE - y1d = arg1d/(2.0*SQRT(arg1)) + y1d = arg1d/(2.0*temp) END IF - y1 = SQRT(arg1) + y1 = temp IF (eps .LT. y1) THEN max1d = y1d max1 = y1 ELSE max1 = eps - max1d = 0.0 + max1d = 0.0_8 END IF invlend = -(one*max1d/max1**2) invlen = one/max1 - normd(1) = normd(1)*invlen + norm(1)*invlend + normd(1) = invlen*normd(1) + norm(1)*invlend norm(1) = norm(1)*invlen - normd(2) = normd(2)*invlen + norm(2)*invlend + normd(2) = invlen*normd(2) + norm(2)*invlend norm(2) = norm(2)*invlen - normd(3) = normd(3)*invlen + norm(3)*invlend + normd(3) = invlen*normd(3) + norm(3)*invlend norm(3) = norm(3)*invlen ! Determine the vector vf from xf to given coordinate. - vfd = 0.0 + vfd = 0.0_8 vfd(1) = xd(1) - x1d(1) vf(1) = x(1) - x1(1) vfd(2) = xd(2) - x1d(2) @@ -127,15 +128,15 @@ SUBROUTINE TRIAPROJECTION_D(x1, x1d, x2, x2d, x3, x3d, x, xd, xf, xfd& vf(3) = x(3) - x1(3) ! Determine the projection of the vector vf onto ! the face. - vnd = vfd(1)*norm(1) + vf(1)*normd(1) + vfd(2)*norm(2) + vf(2)*normd& -& (2) + vfd(3)*norm(3) + vf(3)*normd(3) + vnd = norm(1)*vfd(1) + vf(1)*normd(1) + norm(2)*vfd(2) + vf(2)*normd& +& (2) + norm(3)*vfd(3) + vf(3)*normd(3) vn = vf(1)*norm(1) + vf(2)*norm(2) + vf(3)*norm(3) - vtd = 0.0 - vtd(1) = vfd(1) - vnd*norm(1) - vn*normd(1) + vtd = 0.0_8 + vtd(1) = vfd(1) - norm(1)*vnd - vn*normd(1) vt(1) = vf(1) - vn*norm(1) - vtd(2) = vfd(2) - vnd*norm(2) - vn*normd(2) + vtd(2) = vfd(2) - norm(2)*vnd - vn*normd(2) vt(2) = vf(2) - vn*norm(2) - vtd(3) = vfd(3) - vnd*norm(3) - vn*normd(3) + vtd(3) = vfd(3) - norm(3)*vnd - vn*normd(3) vt(3) = vf(3) - vn*norm(3) ! The vector vt points from the current point on the ! face to the new point. However this new point lies on @@ -146,24 +147,24 @@ SUBROUTINE TRIAPROJECTION_D(x1, x1d, x2, x2d, x3, x3d, x, xd, xf, xfd& ! the coefficients du and dv, such that vt = du*a + dv*b. ! To solve du and dv the vectors normal to a and b ! inside the plane ab are needed. - and = 0.0 - and(1) = ad(2)*norm(3) + a(2)*normd(3) - ad(3)*norm(2) - a(3)*normd(& + and = 0.0_8 + and(1) = norm(3)*ad(2) + a(2)*normd(3) - norm(2)*ad(3) - a(3)*normd(& & 2) an(1) = a(2)*norm(3) - a(3)*norm(2) - and(2) = ad(3)*norm(1) + a(3)*normd(1) - ad(1)*norm(3) - a(1)*normd(& + and(2) = norm(1)*ad(3) + a(3)*normd(1) - norm(3)*ad(1) - a(1)*normd(& & 3) an(2) = a(3)*norm(1) - a(1)*norm(3) - and(3) = ad(1)*norm(2) + a(1)*normd(2) - ad(2)*norm(1) - a(2)*normd(& + and(3) = norm(2)*ad(1) + a(1)*normd(2) - norm(1)*ad(2) - a(2)*normd(& & 1) an(3) = a(1)*norm(2) - a(2)*norm(1) - bnd = 0.0 - bnd(1) = bd(2)*norm(3) + b(2)*normd(3) - bd(3)*norm(2) - b(3)*normd(& + bnd = 0.0_8 + bnd(1) = norm(3)*bd(2) + b(2)*normd(3) - norm(2)*bd(3) - b(3)*normd(& & 2) bn(1) = b(2)*norm(3) - b(3)*norm(2) - bnd(2) = bd(3)*norm(1) + b(3)*normd(1) - bd(1)*norm(3) - b(1)*normd(& + bnd(2) = norm(1)*bd(3) + b(3)*normd(1) - norm(3)*bd(1) - b(1)*normd(& & 3) bn(2) = b(3)*norm(1) - b(1)*norm(3) - bnd(3) = bd(1)*norm(2) + b(1)*normd(2) - bd(2)*norm(1) - b(2)*normd(& + bnd(3) = norm(2)*bd(1) + b(1)*normd(2) - norm(1)*bd(2) - b(2)*normd(& & 1) bn(3) = b(1)*norm(2) - b(2)*norm(1) ! Solve parametric coordinates u and v. @@ -171,8 +172,8 @@ SUBROUTINE TRIAPROJECTION_D(x1, x1d, x2, x2d, x3, x3d, x, xd, xf, xfd& ! active, as this would mean that the vectors a and b ! are parallel. This corresponds to a tria degenerated ! to a line, which should not occur in the surface mesh. - vnd = ad(1)*bn(1) + a(1)*bnd(1) + ad(2)*bn(2) + a(2)*bnd(2) + ad(3)*& -& bn(3) + a(3)*bnd(3) + vnd = bn(1)*ad(1) + a(1)*bnd(1) + bn(2)*ad(2) + a(2)*bnd(2) + bn(3)*& +& ad(3) + a(3)*bnd(3) vn = a(1)*bn(1) + a(2)*bn(2) + a(3)*bn(3) IF (vn .GE. 0.) THEN y2d = vnd @@ -186,16 +187,16 @@ SUBROUTINE TRIAPROJECTION_D(x1, x1d, x2, x2d, x3, x3d, x, xd, xf, xfd& max2 = y2 ELSE max2 = eps - max2d = 0.0 + max2d = 0.0_8 END IF - vnd = max2d*SIGN(1.d0, max2*vn) + vnd = SIGN(1.d0, max2*vn)*max2d vn = SIGN(max2, vn) - ud = ((vtd(1)*bn(1)+vt(1)*bnd(1)+vtd(2)*bn(2)+vt(2)*bnd(2)+vtd(3)*bn& -& (3)+vt(3)*bnd(3))*vn-(vt(1)*bn(1)+vt(2)*bn(2)+vt(3)*bn(3))*vnd)/vn& -& **2 - u = (vt(1)*bn(1)+vt(2)*bn(2)+vt(3)*bn(3))/vn - vnd = bd(1)*an(1) + b(1)*and(1) + bd(2)*an(2) + b(2)*and(2) + bd(3)*& -& an(3) + b(3)*and(3) + temp = (vt(1)*bn(1)+vt(2)*bn(2)+vt(3)*bn(3))/vn + ud = (bn(1)*vtd(1)+vt(1)*bnd(1)+bn(2)*vtd(2)+vt(2)*bnd(2)+bn(3)*vtd(& +& 3)+vt(3)*bnd(3)-temp*vnd)/vn + u = temp + vnd = an(1)*bd(1) + b(1)*and(1) + an(2)*bd(2) + b(2)*and(2) + an(3)*& +& bd(3) + b(3)*and(3) vn = b(1)*an(1) + b(2)*an(2) + b(3)*an(3) IF (vn .GE. 0.) THEN y3d = vnd @@ -209,21 +210,21 @@ SUBROUTINE TRIAPROJECTION_D(x1, x1d, x2, x2d, x3, x3d, x, xd, xf, xfd& max3 = y3 ELSE max3 = eps - max3d = 0.0 + max3d = 0.0_8 END IF - vnd = max3d*SIGN(1.d0, max3*vn) + vnd = SIGN(1.d0, max3*vn)*max3d vn = SIGN(max3, vn) - vd = ((vtd(1)*an(1)+vt(1)*and(1)+vtd(2)*an(2)+vt(2)*and(2)+vtd(3)*an& -& (3)+vt(3)*and(3))*vn-(vt(1)*an(1)+vt(2)*an(2)+vt(3)*an(3))*vnd)/vn& -& **2 - v = (vt(1)*an(1)+vt(2)*an(2)+vt(3)*an(3))/vn + temp = (vt(1)*an(1)+vt(2)*an(2)+vt(3)*an(3))/vn + vd = (an(1)*vtd(1)+vt(1)*and(1)+an(2)*vtd(2)+vt(2)*and(2)+an(3)*vtd(& +& 3)+vt(3)*and(3)-temp*vnd)/vn + v = temp ! Triangles should be bounded by the line u + v = 1 uvd = ud + vd uv = u + v IF (uv .GT. one) THEN - ud = (ud*uv-u*uvd)/uv**2 + ud = (ud-u*uvd/uv)/uv u = u/uv - vd = (vd*uv-v*uvd)/uv**2 + vd = (vd-v*uvd/uv)/uv v = v/uv END IF IF (zero .LT. u) THEN @@ -231,31 +232,31 @@ SUBROUTINE TRIAPROJECTION_D(x1, x1d, x2, x2d, x3, x3d, x, xd, xf, xfd& y4 = u ELSE y4 = zero - y4d = 0.0 + y4d = 0.0_8 END IF IF (one .GT. y4) THEN ud = y4d u = y4 ELSE u = one - ud = 0.0 + ud = 0.0_8 END IF IF (zero .LT. v) THEN y5d = vd y5 = v ELSE y5 = zero - y5d = 0.0 + y5d = 0.0_8 END IF IF (one .GT. y5) THEN vd = y5d v = y5 ELSE v = one - vd = 0.0 + vd = 0.0_8 END IF ! Determine the new coordinates of the point xf. - xfd = x1d + ud*a + u*ad + vd*b + v*bd + xfd = x1d + a*ud + u*ad + b*vd + v*bd xf = x1 + u*a + v*b ! Compute the distance squared between the given ! coordinate and the point xf. @@ -264,6 +265,7 @@ SUBROUTINE TRIAPROJECTION_D(x1, x1d, x2, x2d, x3, x3d, x, xd, xf, xfd& dz = x(3) - xf(3) val = dx*dx + dy*dy + dz*dz END SUBROUTINE TRIAPROJECTION_D + !=============================================================== SUBROUTINE TRIAPROJECTION(x1, x2, x3, x, xf, u, v, val) IMPLICIT NONE @@ -283,10 +285,10 @@ SUBROUTINE TRIAPROJECTION(x1, x2, x3, x, xf, u, v, val) INTRINSIC ABS INTRINSIC SIGN INTRINSIC MIN - REAL(kind=realtype) :: arg1 - REAL(kind=realtype) :: max3 - REAL(kind=realtype) :: max2 REAL(kind=realtype) :: max1 + REAL(kind=realtype) :: max2 + REAL(kind=realtype) :: max3 + REAL(kind=realtype) :: arg1 REAL(kind=realtype) :: y5 REAL(kind=realtype) :: y4 REAL(kind=realtype) :: y3 @@ -405,6 +407,7 @@ SUBROUTINE TRIAPROJECTION(x1, x2, x3, x, xf, u, v, val) dz = x(3) - xf(3) val = dx*dx + dy*dy + dz*dz END SUBROUTINE TRIAPROJECTION + !*************************************************************** !*************************************************************** SUBROUTINE QUADPROJECTION(x1, x2, x3, x4, x, xf, u, v, val) @@ -428,9 +431,9 @@ SUBROUTINE QUADPROJECTION(x1, x2, x3, x4, x, xf, u, v, val) INTRINSIC MAX INTRINSIC MIN INTRINSIC SQRT - REAL(kind=realtype) :: result1 - REAL(kind=realtype) :: y2 REAL(kind=realtype) :: y1 + REAL(kind=realtype) :: y2 + REAL(kind=realtype) :: result1 ! EXECUTION ! Initialize u and v to 0.5 and determine the ! corresponding coordinates on the face, which is the @@ -491,6 +494,7 @@ SUBROUTINE QUADPROJECTION(x1, x2, x3, x4, x, xf, u, v, val) dz = x(3) - xf(3) val = dx*dx + dy*dy + dz*dz END SUBROUTINE QUADPROJECTION + ! Differentiation of quadprojresidual in forward (tangent) mode: ! variations of useful results: residual ! with respect to varying inputs: u v x x1 x2 x3 x4 @@ -539,7 +543,7 @@ SUBROUTINE QUADPROJRESIDUAL_D(x1, x1d, x2, x2d, x3, x3d, x4, x4d, x, & dummyvec = x10 CALL DOTPROD_D(x10, x10d, dummyvec, dummyvecd, dotresult, dotresultd& & ) - ad = 0.0 + ad = 0.0_8 ad(1) = dotresultd a(1) = dotresult CALL DOTPROD_D(x10, x10d, x21, x21d, dotresult, dotresultd) @@ -584,36 +588,36 @@ SUBROUTINE QUADPROJRESIDUAL_D(x1, x1d, x2, x2d, x3, x3d, x4, x4d, x, & graduv(1, 1) = 0.0 graduv(1, 2) = 1.0 graduv(1, 3) = 0.0 - graduvd = 0.0 + graduvd = 0.0_8 graduvd(1, 4) = 2.0*ud graduv(1, 4) = 2.0*u graduvd(1, 5) = vd graduv(1, 5) = v - graduvd(1, 6) = 0.0 + graduvd(1, 6) = 0.0_8 graduv(1, 6) = 0.0 - graduvd(1, 7) = 2.0*(ud*v+u*vd) + graduvd(1, 7) = 2.0*(v*ud+u*vd) graduv(1, 7) = 2.0*u*v - graduvd(1, 8) = vd*v + v*vd + graduvd(1, 8) = 2*v*vd graduv(1, 8) = v*v - graduvd(1, 9) = 2.0*((ud*v+u*vd)*v+u*v*vd) + graduvd(1, 9) = 2.0*(v**2*ud+u*2*v*vd) graduv(1, 9) = 2.0*u*v*v - graduvd(2, 1) = 0.0 + graduvd(2, 1) = 0.0_8 graduv(2, 1) = 0.0 - graduvd(2, 2) = 0.0 + graduvd(2, 2) = 0.0_8 graduv(2, 2) = 0.0 - graduvd(2, 3) = 0.0 + graduvd(2, 3) = 0.0_8 graduv(2, 3) = 1.0 - graduvd(2, 4) = 0.0 + graduvd(2, 4) = 0.0_8 graduv(2, 4) = 0.0 graduvd(2, 5) = ud graduv(2, 5) = u graduvd(2, 6) = 2.0*vd graduv(2, 6) = 2.0*v - graduvd(2, 7) = ud*u + u*ud + graduvd(2, 7) = 2*u*ud graduv(2, 7) = u*u - graduvd(2, 8) = 2.0*(ud*v+u*vd) + graduvd(2, 8) = 2.0*(v*ud+u*vd) graduv(2, 8) = 2.0*u*v - graduvd(2, 9) = 2.0*((ud*u+u*ud)*v+u**2*vd) + graduvd(2, 9) = 2.0*(v*2*u*ud+u**2*vd) graduv(2, 9) = 2.0*u*u*v ! Now compute the gradient of the objective function (grad(dist2)) CALL DOTPROD_D(a, ad, graduv(1, :), graduvd(1, :), graddist2(1), & @@ -631,6 +635,7 @@ SUBROUTINE QUADPROJRESIDUAL_D(x1, x1d, x2, x2d, x3, x3d, x4, x4d, x, & ! Invert the Jacobian CALL INVERT2X2(jac, invjac) END SUBROUTINE QUADPROJRESIDUAL_D + SUBROUTINE QUADPROJRESIDUAL(x1, x2, x3, x4, x, u, v, residual, invjac) IMPLICIT NONE ! DECLARATIONS @@ -713,6 +718,7 @@ SUBROUTINE QUADPROJRESIDUAL(x1, x2, x3, x4, x, u, v, residual, invjac) ! Invert the Jacobian CALL INVERT2X2(jac, invjac) END SUBROUTINE QUADPROJRESIDUAL + ! Differentiation of quadprojoutput in forward (tangent) mode: ! variations of useful results: xf ! with respect to varying inputs: u v x1 x2 x3 x4 @@ -743,10 +749,11 @@ SUBROUTINE QUADPROJOUTPUT_D(x1, x1d, x2, x2d, x3, x3d, x4, x4d, u, ud& x3142d = x3d - x1d - x21d - x41d x3142 = x3 - x1 - x21 - x41 ! Compute guess for projection point - xfd = x1d + ud*x21 + u*x21d + vd*x41 + v*x41d + (ud*v+u*vd)*x3142 + & + xfd = x1d + x21*ud + u*x21d + x41*vd + v*x41d + x3142*(v*ud+u*vd) + & & u*v*x3142d xf = x1 + u*x21 + v*x41 + u*v*x3142 END SUBROUTINE QUADPROJOUTPUT_D + !=============================================================== SUBROUTINE QUADPROJOUTPUT(x1, x2, x3, x4, u, v, xf) IMPLICIT NONE @@ -766,6 +773,7 @@ SUBROUTINE QUADPROJOUTPUT(x1, x2, x3, x4, u, v, xf) ! Compute guess for projection point xf = x1 + u*x21 + v*x41 + u*v*x3142 END SUBROUTINE QUADPROJOUTPUT + ! Differentiation of triaweights in forward (tangent) mode: ! variations of useful results: weight ! with respect to varying inputs: u v @@ -789,7 +797,7 @@ SUBROUTINE TRIAWEIGHTS_D(u, ud, v, vd, weight, weightd) ! Initialize weight vector weight = 0.0 ! Update values according to the current element type - weightd = 0.0 + weightd = 0.0_8 weightd(1) = -ud - vd weight(1) = one - u - v weightd(2) = ud @@ -797,6 +805,7 @@ SUBROUTINE TRIAWEIGHTS_D(u, ud, v, vd, weight, weightd) weightd(3) = vd weight(3) = v END SUBROUTINE TRIAWEIGHTS_D + !=============================================================== !=============================================================== !=============================================================== @@ -818,6 +827,7 @@ SUBROUTINE TRIAWEIGHTS(u, v, weight) weight(2) = u weight(3) = v END SUBROUTINE TRIAWEIGHTS + ! Differentiation of quadweights in forward (tangent) mode: ! variations of useful results: weight ! with respect to varying inputs: u v @@ -838,16 +848,17 @@ SUBROUTINE QUADWEIGHTS_D(u, ud, v, vd, weight, weightd) ! Initialize weight vector weight = 0.0 ! Update values according to the current element type - weightd = 0.0 - weightd(1) = -(ud*(one-v)) - (one-u)*vd + weightd = 0.0_8 + weightd(1) = -((one-v)*ud) - (one-u)*vd weight(1) = (one-u)*(one-v) - weightd(2) = ud*(one-v) - u*vd + weightd(2) = (one-v)*ud - u*vd weight(2) = u*(one-v) - weightd(3) = ud*v + u*vd + weightd(3) = v*ud + u*vd weight(3) = u*v - weightd(4) = (one-u)*vd - ud*v + weightd(4) = (one-u)*vd - v*ud weight(4) = (one-u)*v END SUBROUTINE QUADWEIGHTS_D + !=============================================================== SUBROUTINE QUADWEIGHTS(u, v, weight) IMPLICIT NONE @@ -867,6 +878,7 @@ SUBROUTINE QUADWEIGHTS(u, v, weight) weight(3) = u*v weight(4) = (one-u)*v END SUBROUTINE QUADWEIGHTS + ! Differentiation of computenodalnormals in forward (tangent) mode: ! variations of useful results: nodalnormals ! with respect to varying inputs: coor @@ -906,12 +918,13 @@ SUBROUTINE COMPUTENODALNORMALS_D(ncoor, ntria, nquads, coor, coord, & INTRINSIC SQRT REAL(kind=realtype) :: result1 REAL(kind=realtype) :: result1d + REAL(kind=realtype) :: temp !=============================================================== ! Initialize cumulative variables nodalnormals = 0.0 connect_count = 0 - nodalnormalsd = 0.0 - normal1d = 0.0 + nodalnormalsd = 0.0_8 + normal1d = 0.0_8 ! Loop over triangle connectivities DO i=1,ntria ! Get the indices for each node of the triangle element @@ -937,13 +950,14 @@ SUBROUTINE COMPUTENODALNORMALS_D(ncoor, ntria, nquads, coor, coord, & dummyvec = normal1 CALL DOTPROD_D(normal1, normal1d, dummyvec, dummyvecd, dotresult, & & dotresultd) + temp = SQRT(dotresult) IF (dotresult .EQ. 0.0) THEN - result1d = 0.0 + result1d = 0.0_8 ELSE - result1d = dotresultd/(2.0*SQRT(dotresult)) + result1d = dotresultd/(2.0*temp) END IF - result1 = SQRT(dotresult) - normal1d = (normal1d*result1-normal1*result1d)/result1**2 + result1 = temp + normal1d = (normal1d-normal1*result1d/result1)/result1 normal1 = normal1/result1 ! Add the contribution of this normal to the nodalNormals array nodalnormalsd(:, ind1) = nodalnormalsd(:, ind1) + normal1d @@ -988,13 +1002,14 @@ SUBROUTINE COMPUTENODALNORMALS_D(ncoor, ntria, nquads, coor, coord, & dummyvec = normal1 CALL DOTPROD_D(normal1, normal1d, dummyvec, dummyvecd, dotresult, & & dotresultd) + temp = SQRT(dotresult) IF (dotresult .EQ. 0.0) THEN - result1d = 0.0 + result1d = 0.0_8 ELSE - result1d = dotresultd/(2.0*SQRT(dotresult)) + result1d = dotresultd/(2.0*temp) END IF - result1 = SQRT(dotresult) - normal1d = (normal1d*result1-normal1*result1d)/result1**2 + result1 = temp + normal1d = (normal1d-normal1*result1d/result1)/result1 normal1 = normal1/result1 ! Add the contribution of this normal to the nodalNormals array nodalnormalsd(:, ind1) = nodalnormalsd(:, ind1) + normal1d @@ -1027,17 +1042,18 @@ SUBROUTINE COMPUTENODALNORMALS_D(ncoor, ntria, nquads, coor, coord, & dummyvec = normal1 CALL DOTPROD_D(normal1, normal1d, dummyvec, dummyvecd, dotresult, & & dotresultd) + temp = SQRT(dotresult) IF (dotresult .EQ. 0.0) THEN - result1d = 0.0 + result1d = 0.0_8 ELSE - result1d = dotresultd/(2.0*SQRT(dotresult)) + result1d = dotresultd/(2.0*temp) END IF - result1 = SQRT(dotresult) - nodalnormalsd(:, i) = (normal1d*result1-normal1*result1d)/result1& -& **2 + result1 = temp + nodalnormalsd(:, i) = (normal1d-normal1*result1d/result1)/result1 nodalnormals(:, i) = normal1/result1 END DO END SUBROUTINE COMPUTENODALNORMALS_D + !=============================================================== !=============================================================== !=============================================================== @@ -1150,6 +1166,7 @@ SUBROUTINE COMPUTENODALNORMALS(ncoor, ntria, nquads, coor, triaconn, & nodalnormals(:, i) = normal1/result1 END DO END SUBROUTINE COMPUTENODALNORMALS + ! Differentiation of crossprod in forward (tangent) mode: ! variations of useful results: c ! with respect to varying inputs: a b c @@ -1162,13 +1179,14 @@ SUBROUTINE CROSSPROD_D(a, ad, b, bd, c, cd) REAL(kind=realtype), INTENT(IN) :: ad(3), bd(3) REAL(kind=realtype), INTENT(OUT) :: c(3) REAL(kind=realtype), INTENT(OUT) :: cd(3) - cd(1) = ad(2)*b(3) + a(2)*bd(3) - ad(3)*b(2) - a(3)*bd(2) + cd(1) = b(3)*ad(2) + a(2)*bd(3) - b(2)*ad(3) - a(3)*bd(2) c(1) = a(2)*b(3) - a(3)*b(2) - cd(2) = ad(3)*b(1) + a(3)*bd(1) - ad(1)*b(3) - a(1)*bd(3) + cd(2) = b(1)*ad(3) + a(3)*bd(1) - b(3)*ad(1) - a(1)*bd(3) c(2) = a(3)*b(1) - a(1)*b(3) - cd(3) = ad(1)*b(2) + a(1)*bd(2) - ad(2)*b(1) - a(2)*bd(1) + cd(3) = b(2)*ad(1) + a(1)*bd(2) - b(1)*ad(2) - a(2)*bd(1) c(3) = a(1)*b(2) - a(2)*b(1) END SUBROUTINE CROSSPROD_D + !=============================================================== !=============================================================== !=============================================================== @@ -1180,6 +1198,7 @@ SUBROUTINE CROSSPROD(a, b, c) c(2) = a(3)*b(1) - a(1)*b(3) c(3) = a(1)*b(2) - a(2)*b(1) END SUBROUTINE CROSSPROD + ! Differentiation of dotprod in forward (tangent) mode: ! variations of useful results: c ! with respect to varying inputs: a b @@ -1197,9 +1216,10 @@ SUBROUTINE DOTPROD_D(a, ad, b, bd, c, cd) INTEGER(kind=inttype) :: ii INTRINSIC SUM ! EXECUTION - cd = SUM(ad*b + a*bd) + cd = SUM(b*ad + a*bd) c = SUM(a*b) END SUBROUTINE DOTPROD_D + !=============================================================== SUBROUTINE DOTPROD(a, b, c) IMPLICIT NONE @@ -1214,6 +1234,7 @@ SUBROUTINE DOTPROD(a, b, c) ! EXECUTION c = SUM(a*b) END SUBROUTINE DOTPROD + !=============================================================== SUBROUTINE INVERT2X2(a, ainv) IMPLICIT NONE @@ -1233,4 +1254,6 @@ SUBROUTINE INVERT2X2(a, ainv) ainv(2, 1) = -(a(2, 1)*detinv) ainv(2, 2) = a(1, 1)*detinv END SUBROUTINE INVERT2X2 + END MODULE ADTPROJECTIONS_D + diff --git a/src/adjoint/curveutils_b.f90 b/src/adjoint/curveUtils_b.f90 similarity index 91% rename from src/adjoint/curveutils_b.f90 rename to src/adjoint/curveUtils_b.f90 index 5e225ec..bfafd5a 100644 --- a/src/adjoint/curveutils_b.f90 +++ b/src/adjoint/curveUtils_b.f90 @@ -1,5 +1,5 @@ -! Generated by TAPENADE (INRIA, Tropics team) -! Tapenade 3.10 (r5363) - 9 Sep 2014 09:53 +! Generated by TAPENADE (INRIA, Ecuador team) +! Tapenade 3.16 (master) - 9 Oct 2020 17:47 ! MODULE CURVEUTILS_B USE PRECISION @@ -54,31 +54,32 @@ SUBROUTINE BARPROJECTION_B(x1, x1b, x2, x2b, x, xb, xf, xfb, u) ELSE CALL PUSHCONTROL2B(2) END IF - x1b = 0.0 - x21b = 0.0 + x1b = 0.0_8 + x21b = 0.0_8 x1b = xfb ub = SUM(x21*xfb) x21b = u*xfb CALL POPCONTROL2B(branch) IF (branch .EQ. 0) THEN - ub = 0.0 + ub = 0.0_8 ELSE IF (branch .EQ. 1) THEN - ub = 0.0 + ub = 0.0_8 END IF dotresultb = ub/mag2 mag2b = -(dotresult*ub/mag2**2) - p1b = 0.0 + p1b = 0.0_8 CALL DOT_B0(x21, x21b, p1, p1b, dotresult, dotresultb) - xb = 0.0 + xb = 0.0_8 xb = p1b - dummyvecb = 0.0 + dummyvecb = 0.0_8 CALL DOT_B0(x21, x21b, dummyvec, dummyvecb, mag2, mag2b) x21b = x21b + dummyvecb - x1b = x1b - x21b - p1b - x2b = 0.0 + x1b = x1b - p1b - x21b + x2b = 0.0_8 x2b = x21b - xfb = 0.0 + xfb = 0.0_8 END SUBROUTINE BARPROJECTION_B + SUBROUTINE BARPROJECTION(x1, x2, x, xf, u) ! This subroutine projects the point x onto the bar element defined by points ! x1 and x2, to obtain the projected point xf. @@ -115,6 +116,7 @@ SUBROUTINE BARPROJECTION(x1, x2, x, xf, u) ! Compute the new projected point coordinates in the global frame xf = x1 + u*x21 END SUBROUTINE BARPROJECTION + ! Differentiation of computetangent in reverse (adjoint) mode: ! gradient of useful results: tangent x1 x2 ! with respect to varying inputs: tangent x1 x2 @@ -142,24 +144,25 @@ SUBROUTINE COMPUTETANGENT_B(x1, x1b, x2, x2b, tangent, tangentb) ! EXECUTION ! Get the relative vectors for the bar element x21 = x2 - x1 -! Normalize vector (dot defined in Utilities.F90) +! Normalize vector (dot defined in utilities.F90) dummyvec = x21 CALL DOT(x21, dummyvec, dotresult) - x21b = 0.0 + x21b = 0.0_8 temp = SQRT(dotresult) x21b = tangentb/temp IF (dotresult .EQ. 0.0) THEN - dotresultb = 0.0 + dotresultb = 0.0_8 ELSE - dotresultb = SUM(-(x21*tangentb/temp))/(temp**2*2.0) + dotresultb = -(SUM(x21*tangentb)/(2.0*temp**3)) END IF - dummyvecb = 0.0 + dummyvecb = 0.0_8 CALL DOT_B0(x21, x21b, dummyvec, dummyvecb, dotresult, dotresultb) x21b = x21b + dummyvecb x2b = x2b + x21b x1b = x1b - x21b - tangentb = 0.0 + tangentb = 0.0_8 END SUBROUTINE COMPUTETANGENT_B + SUBROUTINE COMPUTETANGENT(x1, x2, tangent) ! This subroutine computes a normalized vector pointing from x1 to x2 ! @@ -178,9 +181,11 @@ SUBROUTINE COMPUTETANGENT(x1, x2, tangent) ! EXECUTION ! Get the relative vectors for the bar element x21 = x2 - x1 -! Normalize vector (dot defined in Utilities.F90) +! Normalize vector (dot defined in utilities.F90) dummyvec = x21 CALL DOT(x21, dummyvec, dotresult) tangent = x21/SQRT(dotresult) END SUBROUTINE COMPUTETANGENT + END MODULE CURVEUTILS_B + diff --git a/src/adjoint/curveutils_d.f90 b/src/adjoint/curveUtils_d.f90 similarity index 90% rename from src/adjoint/curveutils_d.f90 rename to src/adjoint/curveUtils_d.f90 index 4a45caf..a93b7bf 100644 --- a/src/adjoint/curveutils_d.f90 +++ b/src/adjoint/curveUtils_d.f90 @@ -1,5 +1,5 @@ -! Generated by TAPENADE (INRIA, Tropics team) -! Tapenade 3.10 (r5363) - 9 Sep 2014 09:53 +! Generated by TAPENADE (INRIA, Ecuador team) +! Tapenade 3.16 (master) - 9 Oct 2020 17:47 ! MODULE CURVEUTILS_D USE PRECISION @@ -44,21 +44,22 @@ SUBROUTINE BARPROJECTION_D(x1, x1d, x2, x2d, x, xd, xf, xfd, u) p1 = x - x1 ! Compute the amount of the point that projects onto the element CALL DOT_D0(x21, x21d, p1, p1d, dotresult, dotresultd) - ud = (dotresultd*mag2-dotresult*mag2d)/mag2**2 + ud = (dotresultd-dotresult*mag2d/mag2)/mag2 u = dotresult/mag2 ! Set the projected point to either the start or end node if ! the projection lies outside the node IF (u .LT. 0) THEN u = 0 - ud = 0.0 + ud = 0.0_8 ELSE IF (u .GT. 1) THEN u = 1 - ud = 0.0 + ud = 0.0_8 END IF ! Compute the new projected point coordinates in the global frame - xfd = x1d + ud*x21 + u*x21d + xfd = x1d + x21*ud + u*x21d xf = x1 + u*x21 END SUBROUTINE BARPROJECTION_D + SUBROUTINE BARPROJECTION(x1, x2, x, xf, u) ! This subroutine projects the point x onto the bar element defined by points ! x1 and x2, to obtain the projected point xf. @@ -95,6 +96,7 @@ SUBROUTINE BARPROJECTION(x1, x2, x, xf, u) ! Compute the new projected point coordinates in the global frame xf = x1 + u*x21 END SUBROUTINE BARPROJECTION + ! Differentiation of computetangent in forward (tangent) mode: ! variations of useful results: tangent ! with respect to varying inputs: x1 x2 @@ -120,23 +122,26 @@ SUBROUTINE COMPUTETANGENT_D(x1, x1d, x2, x2d, tangent, tangentd) INTRINSIC SQRT REAL(kind=realtype) :: result1 REAL(kind=realtype) :: result1d + REAL(kind=realtype) :: temp ! EXECUTION ! Get the relative vectors for the bar element x21d = x2d - x1d x21 = x2 - x1 -! Normalize vector (dot defined in Utilities.F90) +! Normalize vector (dot defined in utilities.F90) dummyvecd = x21d dummyvec = x21 CALL DOT_D0(x21, x21d, dummyvec, dummyvecd, dotresult, dotresultd) + temp = SQRT(dotresult) IF (dotresult .EQ. 0.0) THEN - result1d = 0.0 + result1d = 0.0_8 ELSE - result1d = dotresultd/(2.0*SQRT(dotresult)) + result1d = dotresultd/(2.0*temp) END IF - result1 = SQRT(dotresult) - tangentd = (x21d*result1-x21*result1d)/result1**2 + result1 = temp + tangentd = (x21d-x21*result1d/result1)/result1 tangent = x21/result1 END SUBROUTINE COMPUTETANGENT_D + SUBROUTINE COMPUTETANGENT(x1, x2, tangent) ! This subroutine computes a normalized vector pointing from x1 to x2 ! @@ -156,10 +161,12 @@ SUBROUTINE COMPUTETANGENT(x1, x2, tangent) ! EXECUTION ! Get the relative vectors for the bar element x21 = x2 - x1 -! Normalize vector (dot defined in Utilities.F90) +! Normalize vector (dot defined in utilities.F90) dummyvec = x21 CALL DOT(x21, dummyvec, dotresult) result1 = SQRT(dotresult) tangent = x21/result1 END SUBROUTINE COMPUTETANGENT + END MODULE CURVEUTILS_D + diff --git a/src/adjoint/intersection_b.f90 b/src/adjoint/intersection_b.f90 index c6ef477..c9538c9 100644 --- a/src/adjoint/intersection_b.f90 +++ b/src/adjoint/intersection_b.f90 @@ -1,5 +1,5 @@ -! Generated by TAPENADE (INRIA, Tropics team) -! Tapenade 3.10 (r5363) - 9 Sep 2014 09:53 +! Generated by TAPENADE (INRIA, Ecuador team) +! Tapenade 3.16 (master) - 9 Oct 2020 17:47 ! MODULE INTERSECTION_B USE UTILITIES_B @@ -156,6 +156,7 @@ SUBROUTINE FILTERELEMENTS(coor, triaconn, quadsconn, bbox, innertriaid& DEALLOCATE(extinnertriaid) DEALLOCATE(extinnerquadsid) END SUBROUTINE FILTERELEMENTS + !============================================================ SUBROUTINE CONDENSEBARFES(disttol, coor, barsconn, newcoor) IMPLICIT NONE @@ -172,8 +173,8 @@ SUBROUTINE CONDENSEBARFES(disttol, coor, barsconn, newcoor) INTEGER(kind=inttype) :: currnodeid, prevnodeid, link, elemid REAL(kind=realtype), DIMENSION(3) :: currcoor, prevcoor REAL(kind=realtype) :: dist - INTEGER(kind=inttype), DIMENSION(SIZE(coor, 2)) :: linkold2new INTRINSIC SIZE + INTEGER(kind=inttype), DIMENSION(SIZE(coor, 2)) :: linkold2new REAL(kind=realtype), DIMENSION(3) :: arg1 ! EXECUTION ! Get problem size @@ -244,6 +245,7 @@ SUBROUTINE CONDENSEBARFES(disttol, coor, barsconn, newcoor) barsconn(2, elemid) = linkold2new(barsconn(2, elemid)) END DO END SUBROUTINE CONDENSEBARFES + !============================================================ SUBROUTINE GETALLTRIAS(triaconn, quadsconn, innertriaid, innerquadsid& & , alltriaconn) @@ -282,6 +284,7 @@ SUBROUTINE GETALLTRIAS(triaconn, quadsconn, innertriaid, innerquadsid& alltriaconn(:, ninnertria+2*ii) = (/node3, node4, node1/) END DO END SUBROUTINE GETALLTRIAS + ! Differentiation of tritriintersect in reverse (adjoint) mode: ! gradient of useful results: v0 v1 v2 vecend vecstart u0 ! u1 u2 @@ -340,9 +343,9 @@ SUBROUTINE TRITRIINTERSECT_B(v0, v0b, v1, v1b, v2, v2b, u0, u0b, u1, & INTRINSIC ABS INTRINSIC MAX INTRINSIC MIN - INTEGER :: branch - REAL(kind=realtype) :: min1 REAL(kind=realtype) :: max1 + REAL(kind=realtype) :: min1 + INTEGER :: branch ! Initialize intersect and coplanar values so the program does not stop prematurely intersect = 2 coplanar = 0 @@ -365,9 +368,9 @@ SUBROUTINE TRITRIINTERSECT_B(v0, v0b, v1, v1b, v2, v2b, u0, u0b, u1, & ! If all the points of one triangle are on the same side of the other triangle, ! there is no intersection IF (du0du1 .GT. 0.0 .AND. du0du2 .GT. 0.0) THEN - du0b = 0.0 - du1b = 0.0 - du2b = 0.0 + du0b = 0.0_8 + du1b = 0.0_8 + du2b = 0.0_8 ELSE ! Compute plane of triangle (U0, U1, U2) e1 = u1 - u0 @@ -388,12 +391,12 @@ SUBROUTINE TRITRIINTERSECT_B(v0, v0b, v1, v1b, v2, v2b, u0, u0b, u1, & ! If all the points of one triangle are on the same side of the other triangle, ! there is no intersection IF (dv0dv1 .GT. 0.0 .AND. dv0dv2 .GT. 0.0) THEN - dv0b = 0.0 - dv1b = 0.0 - dv2b = 0.0 - du0b = 0.0 - du1b = 0.0 - du2b = 0.0 + dv0b = 0.0_8 + dv1b = 0.0_8 + dv2b = 0.0_8 + du0b = 0.0_8 + du1b = 0.0_8 + du2b = 0.0_8 ELSE ! Compute the direction of the intersection line CALL CROSS_PRODUCT(n1, n2, dir) @@ -435,11 +438,11 @@ SUBROUTINE TRITRIINTERSECT_B(v0, v0b, v1, v1b, v2, v2b, u0, u0b, u1, & & , isect1(2), isectpointa1, & & isectpointa2, coplanar, intersect) IF (intersect .EQ. 0) THEN - isectpointa1b = 0.0 - isectpointa2b = 0.0 - du0b = 0.0 - du1b = 0.0 - du2b = 0.0 + isectpointa1b = 0.0_8 + isectpointa2b = 0.0_8 + du0b = 0.0_8 + du1b = 0.0_8 + du2b = 0.0_8 ELSE ! Compute the intersection interval for the U points CALL COMPUTE_INTERVALS_ISECTLINE(u0, u1, u2, up0, up1, up2, & @@ -448,10 +451,10 @@ SUBROUTINE TRITRIINTERSECT_B(v0, v0b, v1, v1b, v2, v2b, u0, u0b, u1, & & , isectpointb2, coplanar, intersect& & ) IF (intersect .EQ. 0) THEN - isectpointa1b = 0.0 - isectpointa2b = 0.0 - isectpointb1b = 0.0 - isectpointb2b = 0.0 + isectpointa1b = 0.0_8 + isectpointa2b = 0.0_8 + isectpointb1b = 0.0_8 + isectpointb2b = 0.0_8 ELSE ! Sort the projected intersections so that the first index contains the ! smallest value. Also index which case has the smallest max so we @@ -461,10 +464,10 @@ SUBROUTINE TRITRIINTERSECT_B(v0, v0b, v1, v1b, v2, v2b, u0, u0b, u1, & ! If there is no interval where the isects overlap, there there is no intersection IF (isect1(2) .LT. isect2(1) .OR. isect2(2) .LT. isect1(1)) & & THEN - isectpointa1b = 0.0 - isectpointa2b = 0.0 - isectpointb1b = 0.0 - isectpointb2b = 0.0 + isectpointa1b = 0.0_8 + isectpointa2b = 0.0_8 + isectpointb1b = 0.0_8 + isectpointb2b = 0.0_8 ELSE IF (isect1(1) .LT. isect2(1)) THEN max1 = isect2(1) @@ -477,10 +480,10 @@ SUBROUTINE TRITRIINTERSECT_B(v0, v0b, v1, v1b, v2, v2b, u0, u0b, u1, & min1 = isect1(2) END IF IF (max1 .EQ. min1) THEN - isectpointa1b = 0.0 - isectpointa2b = 0.0 - isectpointb1b = 0.0 - isectpointb2b = 0.0 + isectpointa1b = 0.0_8 + isectpointa2b = 0.0_8 + isectpointb1b = 0.0_8 + isectpointb2b = 0.0_8 ELSE IF (coplanar .NE. 1) THEN IF (isect2(1) .LT. isect1(1)) THEN IF (smallest1 .EQ. 0) THEN @@ -490,28 +493,28 @@ SUBROUTINE TRITRIINTERSECT_B(v0, v0b, v1, v1b, v2, v2b, u0, u0b, u1, & END IF IF (isect2(2) .LT. isect1(2)) THEN IF (smallest2 .EQ. 0) THEN - isectpointb2b = 0.0 + isectpointb2b = 0.0_8 isectpointb2b = vecendb - isectpointb1b = 0.0 + isectpointb1b = 0.0_8 ELSE - isectpointb1b = 0.0 + isectpointb1b = 0.0_8 isectpointb1b = vecendb - isectpointb2b = 0.0 + isectpointb2b = 0.0_8 END IF - isectpointa1b = 0.0 - isectpointa2b = 0.0 + isectpointa1b = 0.0_8 + isectpointa2b = 0.0_8 ELSE IF (smallest1 .EQ. 0) THEN - isectpointa2b = 0.0 + isectpointa2b = 0.0_8 isectpointa2b = vecendb - isectpointa1b = 0.0 + isectpointa1b = 0.0_8 ELSE - isectpointa1b = 0.0 + isectpointa1b = 0.0_8 isectpointa1b = vecendb - isectpointa2b = 0.0 + isectpointa2b = 0.0_8 END IF - isectpointb1b = 0.0 - isectpointb2b = 0.0 + isectpointb1b = 0.0_8 + isectpointb2b = 0.0_8 END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN @@ -527,28 +530,28 @@ SUBROUTINE TRITRIINTERSECT_B(v0, v0b, v1, v1b, v2, v2b, u0, u0b, u1, & END IF IF (isect2(2) .GT. isect1(2)) THEN IF (smallest1 .EQ. 0) THEN - isectpointa2b = 0.0 + isectpointa2b = 0.0_8 isectpointa2b = vecendb - isectpointa1b = 0.0 + isectpointa1b = 0.0_8 ELSE - isectpointa1b = 0.0 + isectpointa1b = 0.0_8 isectpointa1b = vecendb - isectpointa2b = 0.0 + isectpointa2b = 0.0_8 END IF - isectpointb1b = 0.0 - isectpointb2b = 0.0 + isectpointb1b = 0.0_8 + isectpointb2b = 0.0_8 ELSE IF (smallest2 .EQ. 0) THEN - isectpointb2b = 0.0 + isectpointb2b = 0.0_8 isectpointb2b = vecendb - isectpointb1b = 0.0 + isectpointb1b = 0.0_8 ELSE - isectpointb1b = 0.0 + isectpointb1b = 0.0_8 isectpointb1b = vecendb - isectpointb2b = 0.0 + isectpointb2b = 0.0_8 END IF - isectpointa1b = 0.0 - isectpointa2b = 0.0 + isectpointa1b = 0.0_8 + isectpointa2b = 0.0_8 END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN @@ -557,13 +560,13 @@ SUBROUTINE TRITRIINTERSECT_B(v0, v0b, v1, v1b, v2, v2b, u0, u0b, u1, & isectpointb2b = isectpointb2b + vecstartb END IF END IF - vecendb = 0.0 - vecstartb = 0.0 + vecendb = 0.0_8 + vecstartb = 0.0_8 ELSE - isectpointa1b = 0.0 - isectpointa2b = 0.0 - isectpointb1b = 0.0 - isectpointb2b = 0.0 + isectpointa1b = 0.0_8 + isectpointa2b = 0.0_8 + isectpointb1b = 0.0_8 + isectpointb2b = 0.0_8 END IF END IF END IF @@ -582,8 +585,8 @@ SUBROUTINE TRITRIINTERSECT_B(v0, v0b, v1, v1b, v2, v2b, u0, u0b, u1, & & isectpointa1b, isectpointa2, & & isectpointa2b, coplanar, intersect) END IF - d2b = dv1b + dv0b + dv2b - n2b = 0.0 + d2b = dv2b + dv1b + dv0b + n2b = 0.0_8 CALL DOT_B0(n2, n2b, v2, v2b, dv2, dv2b) CALL DOT_B0(n2, n2b, v1, v1b, dv1, dv1b) CALL DOT_B0(n2, n2b, v0, v0b, dv0, dv0b) @@ -591,11 +594,11 @@ SUBROUTINE TRITRIINTERSECT_B(v0, v0b, v1, v1b, v2, v2b, u0, u0b, u1, & CALL DOT_B0(n2, n2b, u0, u0b, d2, d2b) CALL CROSS_PRODUCT_B(e1, e1b, e2, e2b, n2, n2b) u2b = u2b + e2b - u0b = u0b - e1b - e2b + u0b = u0b - e2b - e1b u1b = u1b + e1b END IF - d1b = du1b + du0b + du2b - n1b = 0.0 + d1b = du2b + du1b + du0b + n1b = 0.0_8 CALL DOT_B0(n1, n1b, u2, u2b, du2, du2b) CALL DOT_B0(n1, n1b, u1, u1b, du1, du1b) CALL DOT_B0(n1, n1b, u0, u0b, du0, du0b) @@ -605,9 +608,10 @@ SUBROUTINE TRITRIINTERSECT_B(v0, v0b, v1, v1b, v2, v2b, u0, u0b, u1, & e2 = v2 - v0 CALL CROSS_PRODUCT_B(e1, e1b, e2, e2b, n1, n1b) v2b = v2b + e2b - v0b = v0b - e1b - e2b + v0b = v0b - e2b - e1b v1b = v1b + e1b END SUBROUTINE TRITRIINTERSECT_B + !============================================================ SUBROUTINE TRITRIINTERSECT(v0, v1, v2, u0, u1, u2, intersect, vecstart& & , vecend) @@ -652,8 +656,8 @@ SUBROUTINE TRITRIINTERSECT(v0, v1, v2, u0, u1, u2, intersect, vecstart& INTRINSIC ABS INTRINSIC MAX INTRINSIC MIN - REAL(kind=realtype) :: min1 REAL(kind=realtype) :: max1 + REAL(kind=realtype) :: min1 ! Initialize intersect and coplanar values so the program does not stop prematurely intersect = 2 coplanar = 0 @@ -822,6 +826,7 @@ SUBROUTINE TRITRIINTERSECT(v0, v1, v2, u0, u1, u2, intersect, vecstart& END IF END IF END SUBROUTINE TRITRIINTERSECT + ! Differentiation of compute_intervals_isectline in reverse (adjoint) mode: ! gradient of useful results: vert0 vert1 vert2 isectpoint0 ! isectpoint1 @@ -867,11 +872,12 @@ SUBROUTINE COMPUTE_INTERVALS_ISECTLINE_B(vert0, vert0b, vert1, vert1b& & , isectpoint0, isectpoint0b, isectpoint1, isectpoint1b& & ) ELSE - d0b = 0.0 - d1b = 0.0 - d2b = 0.0 + d0b = 0.0_8 + d1b = 0.0_8 + d2b = 0.0_8 END IF END SUBROUTINE COMPUTE_INTERVALS_ISECTLINE_B + SUBROUTINE COMPUTE_INTERVALS_ISECTLINE(vert0, vert1, vert2, vv0, vv1, & & vv2, d0, d1, d2, d0d1, d0d2, isect0, isect1, isectpoint0, & & isectpoint1, coplanar, intersect) @@ -909,6 +915,7 @@ SUBROUTINE COMPUTE_INTERVALS_ISECTLINE(vert0, vert1, vert2, vv0, vv1, & coplanar = 1 END IF END SUBROUTINE COMPUTE_INTERVALS_ISECTLINE + ! Differentiation of intersect2 in reverse (adjoint) mode: ! gradient of useful results: isectpoint0 isectpoint1 vtx0 ! vtx1 vtx2 @@ -928,36 +935,36 @@ SUBROUTINE INTERSECT2_B(vtx0, vtx0b, vtx1, vtx1b, vtx2, vtx2b, vv0, & REAL(kind=realtype) :: tmpb REAL(kind=realtype), DIMENSION(3) :: diff REAL(kind=realtype), DIMENSION(3) :: diffb - REAL(kind=realtype) :: tempb2 - REAL(kind=realtype) :: tempb1 - REAL(kind=realtype) :: tempb0 REAL(kind=realtype) :: tempb + REAL(kind=realtype) :: tempb0 diff = vtx1 - vtx0 tmp = d0/(d0-d2) - CALL PUSHREAL4ARRAY(diff, realtype*3/4) + CALL PUSHREAL8ARRAY(diff, 3) diff = vtx2 - vtx0 - diffb = 0.0 + diffb = 0.0_8 diffb = isectpoint1b tmpb = SUM(diff*diffb) diffb = tmp*diffb vtx0b = vtx0b + isectpoint1b - diffb - CALL POPREAL4ARRAY(diff, realtype*3/4) + CALL POPREAL8ARRAY(diff, 3) vtx2b = vtx2b + diffb - tempb = tmpb/(d0-d2) - tempb0 = -(d0*tempb/(d0-d2)) - d2b = -tempb0 - diffb = 0.0 + tempb0 = tmpb/(d0-d2) + tempb = -(d0*tempb0/(d0-d2)) + d0b = tempb0 + tempb + d2b = -tempb + diffb = 0.0_8 diffb = isectpoint0b tmp = d0/(d0-d1) tmpb = SUM(diff*diffb) diffb = tmp*diffb vtx0b = vtx0b + isectpoint0b - diffb vtx1b = vtx1b + diffb - tempb1 = tmpb/(d0-d1) - tempb2 = -(d0*tempb1/(d0-d1)) - d0b = tempb1 + tempb2 + tempb0 + tempb - d1b = -tempb2 + tempb = tmpb/(d0-d1) + tempb0 = -(d0*tempb/(d0-d1)) + d0b = d0b + tempb + tempb0 + d1b = -tempb0 END SUBROUTINE INTERSECT2_B + SUBROUTINE INTERSECT2(vtx0, vtx1, vtx2, vv0, vv1, vv2, d0, d1, d2, & & isect0, isect1, isectpoint0, isectpoint1) IMPLICIT NONE @@ -978,6 +985,7 @@ SUBROUTINE INTERSECT2(vtx0, vtx1, vtx2, vv0, vv1, vv2, d0, d1, d2, & diff = diff*tmp isectpoint1 = diff + vtx0 END SUBROUTINE INTERSECT2 + FUNCTION COPLANARTRITRI(n, v0, v1, v2, u0, u1, u2) RESULT (INTERSECT) IMPLICIT NONE REAL(kind=realtype), DIMENSION(3), INTENT(IN) :: n, v0, v1, v2, u0, & @@ -1041,6 +1049,7 @@ FUNCTION COPLANARTRITRI(n, v0, v1, v2, u0, u1, u2) RESULT (INTERSECT) END IF END IF END FUNCTION COPLANARTRITRI + FUNCTION POINTINTRI(v0, u0, u1, u2, i0, i1) RESULT (INTERSECT) IMPLICIT NONE REAL(kind=realtype), DIMENSION(3), INTENT(IN) :: v0, u0, u1, u2 @@ -1065,6 +1074,7 @@ FUNCTION POINTINTRI(v0, u0, u1, u2, i0, i1) RESULT (INTERSECT) RETURN END IF END FUNCTION POINTINTRI + FUNCTION EDGEAGAINSTTRIEDGES(v0, v1, u0, u1, u2, i0, i1) RESULT (& & INTERSECT) IMPLICIT NONE @@ -1087,6 +1097,7 @@ FUNCTION EDGEAGAINSTTRIEDGES(v0, v1, u0, u1, u2, i0, i1) RESULT (& END IF END IF END FUNCTION EDGEAGAINSTTRIEDGES + FUNCTION EDGE_EDGE_TEST(v0, u0, u1, ax, ay, i0, i1) RESULT (INTERSECT) IMPLICIT NONE REAL(kind=realtype), DIMENSION(3), INTENT(IN) :: v0, u0, u1 @@ -1113,6 +1124,7 @@ FUNCTION EDGE_EDGE_TEST(v0, u0, u1, ax, ay, i0, i1) RESULT (INTERSECT) END IF END IF END FUNCTION EDGE_EDGE_TEST + ! Differentiation of cross_product in reverse (adjoint) mode: ! gradient of useful results: c ! with respect to varying inputs: a b @@ -1122,23 +1134,18 @@ SUBROUTINE CROSS_PRODUCT_B(a, ab, b, bb, c, cb) REAL(kind=realtype) :: ab(3), bb(3) REAL(kind=realtype) :: c(3) REAL(kind=realtype) :: cb(3) - ab = 0.0 - bb = 0.0 - ab(1) = ab(1) + b(2)*cb(3) - bb(2) = bb(2) + a(1)*cb(3) - ab(2) = ab(2) - b(1)*cb(3) - bb(1) = bb(1) - a(2)*cb(3) - cb(3) = 0.0 - ab(3) = ab(3) + b(1)*cb(2) - bb(1) = bb(1) + a(3)*cb(2) - ab(1) = ab(1) - b(3)*cb(2) - bb(3) = bb(3) - a(1)*cb(2) - cb(2) = 0.0 - ab(2) = ab(2) + b(3)*cb(1) - bb(3) = bb(3) + a(2)*cb(1) - ab(3) = ab(3) - b(2)*cb(1) - bb(2) = bb(2) - a(3)*cb(1) + ab = 0.0_8 + bb = 0.0_8 + ab(1) = ab(1) + b(2)*cb(3) - b(3)*cb(2) + bb(2) = bb(2) + a(1)*cb(3) - a(3)*cb(1) + ab(2) = ab(2) + b(3)*cb(1) - b(1)*cb(3) + bb(1) = bb(1) + a(3)*cb(2) - a(2)*cb(3) + cb(3) = 0.0_8 + ab(3) = ab(3) + b(1)*cb(2) - b(2)*cb(1) + bb(3) = bb(3) + a(2)*cb(1) - a(1)*cb(2) + cb(2) = 0.0_8 END SUBROUTINE CROSS_PRODUCT_B + SUBROUTINE CROSS_PRODUCT(a, b, c) IMPLICIT NONE REAL(kind=realtype), INTENT(IN) :: a(3), b(3) @@ -1147,6 +1154,7 @@ SUBROUTINE CROSS_PRODUCT(a, b, c) c(2) = a(3)*b(1) - a(1)*b(3) c(3) = a(1)*b(2) - a(2)*b(1) END SUBROUTINE CROSS_PRODUCT + SUBROUTINE SORT(a, b, smallest) IMPLICIT NONE REAL(kind=realtype), INTENT(INOUT) :: a, b @@ -1161,4 +1169,6 @@ SUBROUTINE SORT(a, b, smallest) smallest = 0 END IF END SUBROUTINE SORT + END MODULE INTERSECTION_B + diff --git a/src/adjoint/intersection_d.f90 b/src/adjoint/intersection_d.f90 index e65d5ba..f339393 100644 --- a/src/adjoint/intersection_d.f90 +++ b/src/adjoint/intersection_d.f90 @@ -1,5 +1,5 @@ -! Generated by TAPENADE (INRIA, Tropics team) -! Tapenade 3.10 (r5363) - 9 Sep 2014 09:53 +! Generated by TAPENADE (INRIA, Ecuador team) +! Tapenade 3.16 (master) - 9 Oct 2020 17:47 ! MODULE INTERSECTION_D USE UTILITIES_D @@ -156,6 +156,7 @@ SUBROUTINE FILTERELEMENTS(coor, triaconn, quadsconn, bbox, innertriaid& DEALLOCATE(extinnertriaid) DEALLOCATE(extinnerquadsid) END SUBROUTINE FILTERELEMENTS + !============================================================ SUBROUTINE CONDENSEBARFES(disttol, coor, barsconn, newcoor) IMPLICIT NONE @@ -172,8 +173,8 @@ SUBROUTINE CONDENSEBARFES(disttol, coor, barsconn, newcoor) INTEGER(kind=inttype) :: currnodeid, prevnodeid, link, elemid REAL(kind=realtype), DIMENSION(3) :: currcoor, prevcoor REAL(kind=realtype) :: dist - INTEGER(kind=inttype), DIMENSION(SIZE(coor, 2)) :: linkold2new INTRINSIC SIZE + INTEGER(kind=inttype), DIMENSION(SIZE(coor, 2)) :: linkold2new ! EXECUTION ! Get problem size nnodes = SIZE(coor, 2) @@ -242,6 +243,7 @@ SUBROUTINE CONDENSEBARFES(disttol, coor, barsconn, newcoor) barsconn(2, elemid) = linkold2new(barsconn(2, elemid)) END DO END SUBROUTINE CONDENSEBARFES + !============================================================ SUBROUTINE GETALLTRIAS(triaconn, quadsconn, innertriaid, innerquadsid& & , alltriaconn) @@ -280,6 +282,7 @@ SUBROUTINE GETALLTRIAS(triaconn, quadsconn, innertriaid, innerquadsid& alltriaconn(:, ninnertria+2*ii) = (/node3, node4, node1/) END DO END SUBROUTINE GETALLTRIAS + ! Differentiation of tritriintersect in forward (tangent) mode: ! variations of useful results: vecend vecstart ! with respect to varying inputs: v0 v1 v2 vecend vecstart u0 @@ -338,8 +341,8 @@ SUBROUTINE TRITRIINTERSECT_D(v0, v0d, v1, v1d, v2, v2d, u0, u0d, u1, & INTRINSIC ABS INTRINSIC MAX INTRINSIC MIN - REAL(kind=realtype) :: min1 REAL(kind=realtype) :: max1 + REAL(kind=realtype) :: min1 ! Initialize intersect and coplanar values so the program does not stop prematurely intersect = 2 coplanar = 0 @@ -536,6 +539,7 @@ SUBROUTINE TRITRIINTERSECT_D(v0, v0d, v1, v1d, v2, v2d, u0, u0d, u1, & END IF END IF END SUBROUTINE TRITRIINTERSECT_D + !============================================================ SUBROUTINE TRITRIINTERSECT(v0, v1, v2, u0, u1, u2, intersect, vecstart& & , vecend) @@ -580,8 +584,8 @@ SUBROUTINE TRITRIINTERSECT(v0, v1, v2, u0, u1, u2, intersect, vecstart& INTRINSIC ABS INTRINSIC MAX INTRINSIC MIN - REAL(kind=realtype) :: min1 REAL(kind=realtype) :: max1 + REAL(kind=realtype) :: min1 ! Initialize intersect and coplanar values so the program does not stop prematurely intersect = 2 coplanar = 0 @@ -750,6 +754,7 @@ SUBROUTINE TRITRIINTERSECT(v0, v1, v2, u0, u1, u2, intersect, vecstart& END IF END IF END SUBROUTINE TRITRIINTERSECT + ! Differentiation of compute_intervals_isectline in forward (tangent) mode: ! variations of useful results: isectpoint0 isectpoint1 ! with respect to varying inputs: d0 d1 d2 vert0 vert1 vert2 @@ -803,10 +808,11 @@ SUBROUTINE COMPUTE_INTERVALS_ISECTLINE_D(vert0, vert0d, vert1, vert1d& !intersect = coplanarTriTri(N1, V0, V1, V2, U0, U1, U2) intersect = 0 coplanar = 1 - isectpoint0d = 0.0 - isectpoint1d = 0.0 + isectpoint0d = 0.0_8 + isectpoint1d = 0.0_8 END IF END SUBROUTINE COMPUTE_INTERVALS_ISECTLINE_D + SUBROUTINE COMPUTE_INTERVALS_ISECTLINE(vert0, vert1, vert2, vv0, vv1, & & vv2, d0, d1, d2, d0d1, d0d2, isect0, isect1, isectpoint0, & & isectpoint1, coplanar, intersect) @@ -844,6 +850,7 @@ SUBROUTINE COMPUTE_INTERVALS_ISECTLINE(vert0, vert1, vert2, vv0, vv1, & coplanar = 1 END IF END SUBROUTINE COMPUTE_INTERVALS_ISECTLINE + ! Differentiation of intersect2 in forward (tangent) mode: ! variations of useful results: isectpoint0 isectpoint1 ! with respect to varying inputs: d0 d1 d2 vtx0 vtx1 vtx2 @@ -862,25 +869,29 @@ SUBROUTINE INTERSECT2_D(vtx0, vtx0d, vtx1, vtx1d, vtx2, vtx2d, vv0, & REAL(kind=realtype) :: tmpd REAL(kind=realtype), DIMENSION(3) :: diff REAL(kind=realtype), DIMENSION(3) :: diffd - tmpd = (d0d*(d0-d1)-d0*(d0d-d1d))/(d0-d1)**2 - tmp = d0/(d0-d1) + REAL(kind=realtype) :: temp + temp = d0/(d0-d1) + tmpd = (d0d-temp*(d0d-d1d))/(d0-d1) + tmp = temp isect0 = vv0 + (vv1-vv0)*tmp diffd = vtx1d - vtx0d diff = vtx1 - vtx0 - diffd = diffd*tmp + diff*tmpd + diffd = tmp*diffd + diff*tmpd diff = diff*tmp isectpoint0d = diffd + vtx0d isectpoint0 = diff + vtx0 - tmpd = (d0d*(d0-d2)-d0*(d0d-d2d))/(d0-d2)**2 - tmp = d0/(d0-d2) + temp = d0/(d0-d2) + tmpd = (d0d-temp*(d0d-d2d))/(d0-d2) + tmp = temp isect1 = vv0 + (vv2-vv0)*tmp diffd = vtx2d - vtx0d diff = vtx2 - vtx0 - diffd = diffd*tmp + diff*tmpd + diffd = tmp*diffd + diff*tmpd diff = diff*tmp isectpoint1d = diffd + vtx0d isectpoint1 = diff + vtx0 END SUBROUTINE INTERSECT2_D + SUBROUTINE INTERSECT2(vtx0, vtx1, vtx2, vv0, vv1, vv2, d0, d1, d2, & & isect0, isect1, isectpoint0, isectpoint1) IMPLICIT NONE @@ -901,6 +912,7 @@ SUBROUTINE INTERSECT2(vtx0, vtx1, vtx2, vv0, vv1, vv2, d0, d1, d2, & diff = diff*tmp isectpoint1 = diff + vtx0 END SUBROUTINE INTERSECT2 + FUNCTION COPLANARTRITRI(n, v0, v1, v2, u0, u1, u2) RESULT (INTERSECT) IMPLICIT NONE REAL(kind=realtype), DIMENSION(3), INTENT(IN) :: n, v0, v1, v2, u0, & @@ -964,6 +976,7 @@ FUNCTION COPLANARTRITRI(n, v0, v1, v2, u0, u1, u2) RESULT (INTERSECT) END IF END IF END FUNCTION COPLANARTRITRI + FUNCTION POINTINTRI(v0, u0, u1, u2, i0, i1) RESULT (INTERSECT) IMPLICIT NONE REAL(kind=realtype), DIMENSION(3), INTENT(IN) :: v0, u0, u1, u2 @@ -988,6 +1001,7 @@ FUNCTION POINTINTRI(v0, u0, u1, u2, i0, i1) RESULT (INTERSECT) RETURN END IF END FUNCTION POINTINTRI + FUNCTION EDGEAGAINSTTRIEDGES(v0, v1, u0, u1, u2, i0, i1) RESULT (& & INTERSECT) IMPLICIT NONE @@ -1010,6 +1024,7 @@ FUNCTION EDGEAGAINSTTRIEDGES(v0, v1, u0, u1, u2, i0, i1) RESULT (& END IF END IF END FUNCTION EDGEAGAINSTTRIEDGES + FUNCTION EDGE_EDGE_TEST(v0, u0, u1, ax, ay, i0, i1) RESULT (INTERSECT) IMPLICIT NONE REAL(kind=realtype), DIMENSION(3), INTENT(IN) :: v0, u0, u1 @@ -1036,6 +1051,7 @@ FUNCTION EDGE_EDGE_TEST(v0, u0, u1, ax, ay, i0, i1) RESULT (INTERSECT) END IF END IF END FUNCTION EDGE_EDGE_TEST + ! Differentiation of cross_product in forward (tangent) mode: ! variations of useful results: c ! with respect to varying inputs: a b @@ -1045,14 +1061,15 @@ SUBROUTINE CROSS_PRODUCT_D(a, ad, b, bd, c, cd) REAL(kind=realtype), INTENT(IN) :: ad(3), bd(3) REAL(kind=realtype), INTENT(OUT) :: c(3) REAL(kind=realtype), INTENT(OUT) :: cd(3) - cd = 0.0 - cd(1) = ad(2)*b(3) + a(2)*bd(3) - ad(3)*b(2) - a(3)*bd(2) + cd = 0.0_8 + cd(1) = b(3)*ad(2) + a(2)*bd(3) - b(2)*ad(3) - a(3)*bd(2) c(1) = a(2)*b(3) - a(3)*b(2) - cd(2) = ad(3)*b(1) + a(3)*bd(1) - ad(1)*b(3) - a(1)*bd(3) + cd(2) = b(1)*ad(3) + a(3)*bd(1) - b(3)*ad(1) - a(1)*bd(3) c(2) = a(3)*b(1) - a(1)*b(3) - cd(3) = ad(1)*b(2) + a(1)*bd(2) - ad(2)*b(1) - a(2)*bd(1) + cd(3) = b(2)*ad(1) + a(1)*bd(2) - b(1)*ad(2) - a(2)*bd(1) c(3) = a(1)*b(2) - a(2)*b(1) END SUBROUTINE CROSS_PRODUCT_D + SUBROUTINE CROSS_PRODUCT(a, b, c) IMPLICIT NONE REAL(kind=realtype), INTENT(IN) :: a(3), b(3) @@ -1061,6 +1078,7 @@ SUBROUTINE CROSS_PRODUCT(a, b, c) c(2) = a(3)*b(1) - a(1)*b(3) c(3) = a(1)*b(2) - a(2)*b(1) END SUBROUTINE CROSS_PRODUCT + SUBROUTINE SORT(a, b, smallest) IMPLICIT NONE REAL(kind=realtype), INTENT(INOUT) :: a, b @@ -1075,4 +1093,6 @@ SUBROUTINE SORT(a, b, smallest) smallest = 0 END IF END SUBROUTINE SORT + END MODULE INTERSECTION_D + diff --git a/src/adjoint/utilities_b.f90 b/src/adjoint/utilities_b.f90 index 8d80a07..d0e3157 100644 --- a/src/adjoint/utilities_b.f90 +++ b/src/adjoint/utilities_b.f90 @@ -1,5 +1,5 @@ -! Generated by TAPENADE (INRIA, Tropics team) -! Tapenade 3.10 (r5363) - 9 Sep 2014 09:53 +! Generated by TAPENADE (INRIA, Ecuador team) +! Tapenade 3.16 (master) - 9 Oct 2020 17:47 ! MODULE UTILITIES_B USE PRECISION @@ -100,6 +100,7 @@ SUBROUTINE CONDENSEBARNODES_MAIN(nnodes, nelem, disttol, coor, & barsconn(2, elemid) = linkold2new(barsconn(2, elemid)) END DO END SUBROUTINE CONDENSEBARNODES_MAIN + ! Differentiation of remesh_main in reverse (adjoint) mode: ! gradient of useful results: newcoor ! with respect to varying inputs: coor newcoor @@ -118,7 +119,7 @@ SUBROUTINE REMESH_MAIN_B(nnodes, nelem, nnewnodes, coor, coorb, & ! Output variables REAL(kind=realtype), DIMENSION(3, nnewnodes) :: newcoor REAL(kind=realtype), DIMENSION(3, nnewnodes) :: newcoorb - INTEGER(kind=inttype), DIMENSION(2, nnewnodes - 1) :: newbarsconn + INTEGER(kind=inttype), DIMENSION(2, nnewnodes-1) :: newbarsconn ! Working variables REAL(kind=realtype), DIMENSION(3, nnodes) :: nodecoor REAL(kind=realtype), DIMENSION(3, nnodes) :: nodecoorb @@ -206,7 +207,7 @@ SUBROUTINE REMESH_MAIN_B(nnodes, nelem, nnewnodes, coor, coorb, & CALL PUSHCONTROL2B(3) END IF ! Rescale newArcLength based on the final distance - CALL PUSHREAL4ARRAY(newarclength, realtype*nnewnodes/4) + CALL PUSHREAL8ARRAY(newarclength, nnewnodes) newarclength = arclength(nnodes)*newarclength ! INTERPOLATE NEW NODES ! Now we sample the new coordinates based on the interpolation method given by the user @@ -243,18 +244,18 @@ SUBROUTINE REMESH_MAIN_B(nnodes, nelem, nnewnodes, coor, coorb, & END IF END DO END DO - nodecoorb = 0.0 + nodecoorb = 0.0_8 DO ii=nnewnodes,1,-1 DO jj=nnodes,1,-1 CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN nodecoorb(:, jj) = nodecoorb(:, jj) + newcoorb(:, ii) - newcoorb(:, ii) = 0.0 + newcoorb(:, ii) = 0.0_8 END IF END DO END DO - arclengthb = 0.0 - newarclengthb = 0.0 + arclengthb = 0.0_8 + newarclengthb = 0.0_8 CALL INTERP1D_B(1, nnodes, arclength, arclengthb, nodecoor(3, :), & & nodecoorb(3, :), nnewnodes, newarclength, newarclengthb, & & newcoor(3, :), newcoorb(3, :)) @@ -264,7 +265,7 @@ SUBROUTINE REMESH_MAIN_B(nnodes, nelem, nnewnodes, coor, coorb, & CALL INTERP1D_B(1, nnodes, arclength, arclengthb, nodecoor(1, :), & & nodecoorb(1, :), nnewnodes, newarclength, newarclengthb, & & newcoor(1, :), newcoorb(1, :)) - CALL POPREAL4ARRAY(newarclength, realtype*nnewnodes/4) + CALL POPREAL8ARRAY(newarclength, nnewnodes) arclengthb(nnodes) = arclengthb(nnodes) + SUM(newarclength*& & newarclengthb) newarclengthb = arclength(nnodes)*newarclengthb @@ -273,23 +274,23 @@ SUBROUTINE REMESH_MAIN_B(nnodes, nelem, nnewnodes, coor, coorb, & IF (branch .EQ. 2) THEN CALL GETHYPTANDIST_B(arg10, arg10b, arg2, arg2b, nnewnodes, & & newarclength, newarclengthb) - arclengthb(nelem+1) = arclengthb(nelem+1) - sp1*arg10b/arclength& -& (nelem+1)**2 - sp2*arg2b/arclength(nelem+1)**2 + arclengthb(nelem+1) = arclengthb(nelem+1) - sp2*arg2b/arclength(& +& nelem+1)**2 - sp1*arg10b/arclength(nelem+1)**2 END IF END IF - coorb = 0.0 + coorb = 0.0_8 DO elemid=nelem,1,-1 node2 = coor(:, barsconn(2, elemid)) - node2b = 0.0 + node2b = 0.0_8 arclengthb(elemid) = arclengthb(elemid) + arclengthb(elemid+1) distb = arclengthb(elemid+1) - arclengthb(elemid+1) = 0.0 + arclengthb(elemid+1) = 0.0_8 node1 = coor(:, barsconn(1, elemid)) arg1(:) = node1 - node2 CALL NORM_B0(arg1(:), arg1b(:), dist, distb) node2b = nodecoorb(:, elemid+1) - arg1b(:) - nodecoorb(:, elemid+1) = 0.0 - node1b = 0.0 + nodecoorb(:, elemid+1) = 0.0_8 + node1b = 0.0_8 node1b = arg1b(:) coorb(:, barsconn(2, elemid)) = coorb(:, barsconn(2, elemid)) + & & node2b @@ -305,11 +306,12 @@ SUBROUTINE REMESH_MAIN_B(nnodes, nelem, nnewnodes, coor, coorb, & DO i=1,ad_count IF (i .EQ. 1) THEN CALL POPCONTROL1B(branch) - IF (branch .NE. 0) coorb = 0.0 + IF (branch .NE. 0) coorb = 0.0_8 END IF END DO - newcoorb = 0.0 + newcoorb = 0.0_8 END SUBROUTINE REMESH_MAIN_B + SUBROUTINE REMESH_MAIN(nnodes, nelem, nnewnodes, coor, barsconn, & & method, spacing, sp1, sp2, newcoor, newbarsconn) IMPLICIT NONE @@ -322,7 +324,7 @@ SUBROUTINE REMESH_MAIN(nnodes, nelem, nnewnodes, coor, barsconn, & REAL(kind=realtype), INTENT(IN) :: sp1, sp2 ! Output variables REAL(kind=realtype), DIMENSION(3, nnewnodes) :: newcoor - INTEGER(kind=inttype), DIMENSION(2, nnewnodes - 1) :: newbarsconn + INTEGER(kind=inttype), DIMENSION(2, nnewnodes-1) :: newbarsconn ! Working variables REAL(kind=realtype), DIMENSION(3, nnodes) :: nodecoor REAL(kind=realtype), DIMENSION(nnodes) :: arclength @@ -430,11 +432,14 @@ SUBROUTINE REMESH_MAIN(nnodes, nelem, nnewnodes, coor, barsconn, & distvec = newnode - oldnode dist = SQRT(distvec(1)**2 + distvec(2)**2 + distvec(3)**2) ! Check if distance is below a threshold - IF (dist .LT. disttol) newcoor(:, ii) = nodecoor(:, jj) + IF (dist .LT. disttol) THEN ! Repeat the old node to avoid indetermination in derivatives + newcoor(:, ii) = nodecoor(:, jj) + END IF END DO END DO END SUBROUTINE REMESH_MAIN + !============================================================ SUBROUTINE LINSPACE(l, k, n, z) IMPLICIT NONE @@ -455,6 +460,7 @@ SUBROUTINE LINSPACE(l, k, n, z) z(n) = k RETURN END SUBROUTINE LINSPACE + ! Differentiation of interp1d in reverse (adjoint) mode: ! gradient of useful results: p_interp p_data t_data t_interp ! with respect to varying inputs: p_interp p_data t_data t_interp @@ -477,34 +483,37 @@ SUBROUTINE INTERP1D_B(m, data_num, t_data, t_datab, p_data, p_datab, & REAL(kind=realtype) :: t_datab(data_num) REAL(kind=realtype) :: t_interp(interp_num) REAL(kind=realtype) :: t_interpb(interp_num) - REAL(kind=realtype) :: tempb0 REAL(kind=realtype) :: tempb + REAL(kind=realtype) :: tempb0 DO interp=1,interp_num t = t_interp(interp) ! ! Find the interval [ TDATA(LEFT), TDATA(RIGHT) ] that contains, or is ! nearest to, TVAL. ! - CALL PUSHINTEGER4ARRAY(right, inttype/4) - CALL PUSHINTEGER4ARRAY(left, inttype/4) + CALL PUSHINTEGER4(right) + CALL PUSHINTEGER4(left) CALL R8VEC_BRACKET(data_num, t_data, t, left, right) END DO DO interp=interp_num,1,-1 t = t_interp(interp) tempb = p_interpb(interp)/(t_data(right)-t_data(left)) - tempb0 = -(((t_data(right)-t)*p_data(left)+(t-t_data(left))*p_data& -& (right))*tempb/(t_data(right)-t_data(left))) - t_datab(right) = t_datab(right) + tempb0 + p_data(left)*tempb + p_interpb(interp) = 0.0_8 + t_datab(right) = t_datab(right) + p_data(left)*tempb tb = (p_data(right)-p_data(left))*tempb p_datab(left) = p_datab(left) + (t_data(right)-t)*tempb - t_datab(left) = t_datab(left) - tempb0 - p_data(right)*tempb + t_datab(left) = t_datab(left) - p_data(right)*tempb p_datab(right) = p_datab(right) + (t-t_data(left))*tempb - p_interpb(interp) = 0.0 - CALL POPINTEGER4ARRAY(left, inttype/4) - CALL POPINTEGER4ARRAY(right, inttype/4) + tempb0 = -(((t_data(right)-t)*p_data(left)+(t-t_data(left))*p_data& +& (right))*tempb/(t_data(right)-t_data(left))) + t_datab(right) = t_datab(right) + tempb0 + t_datab(left) = t_datab(left) - tempb0 + CALL POPINTEGER4(left) + CALL POPINTEGER4(right) t_interpb(interp) = t_interpb(interp) + tb END DO END SUBROUTINE INTERP1D_B + SUBROUTINE INTERP1D(m, data_num, t_data, p_data, interp_num, t_interp& & , p_interp) IMPLICIT NONE @@ -531,6 +540,7 @@ SUBROUTINE INTERP1D(m, data_num, t_data, p_data, interp_num, t_interp& END DO RETURN END SUBROUTINE INTERP1D + SUBROUTINE R8VEC_BRACKET(n, x, xval, left, right) IMPLICIT NONE INTEGER(kind=inttype) :: n @@ -550,6 +560,7 @@ SUBROUTINE R8VEC_BRACKET(n, x, xval, left, right) right = n RETURN END SUBROUTINE R8VEC_BRACKET + ! Differentiation of dot in reverse (adjoint) mode: ! gradient of useful results: dot_ a b ! with respect to varying inputs: a b @@ -564,6 +575,7 @@ SUBROUTINE DOT_B0(a, ab, b, bb, dot_, dot_b) ab = ab + b*dot_b bb = bb + a*dot_b END SUBROUTINE DOT_B0 + !============================================================ SUBROUTINE DOT(a, b, dot_) IMPLICIT NONE @@ -572,6 +584,7 @@ SUBROUTINE DOT(a, b, dot_) INTRINSIC SUM dot_ = SUM(a*b) END SUBROUTINE DOT + ! Differentiation of norm in reverse (adjoint) mode: ! gradient of useful results: norm_ ! with respect to varying inputs: a @@ -584,9 +597,9 @@ SUBROUTINE NORM_B0(a, ab, norm_, norm_b) REAL(kind=realtype) :: norm_b INTRINSIC SQRT REAL(kind=realtype) :: tempb - ab = 0.0 + ab = 0.0_8 IF (a(1)**2 + a(2)**2 + a(3)**2 .EQ. 0.0) THEN - tempb = 0.0 + tempb = 0.0_8 ELSE tempb = norm_b/(2.0*SQRT(a(1)**2+a(2)**2+a(3)**2)) END IF @@ -594,6 +607,7 @@ SUBROUTINE NORM_B0(a, ab, norm_, norm_b) ab(2) = ab(2) + 2*a(2)*tempb ab(3) = ab(3) + 2*a(3)*tempb END SUBROUTINE NORM_B0 + !============================================================ SUBROUTINE NORM(a, norm_) IMPLICIT NONE @@ -602,6 +616,7 @@ SUBROUTINE NORM(a, norm_) INTRINSIC SQRT norm_ = SQRT(a(1)*a(1) + a(2)*a(2) + a(3)*a(3)) END SUBROUTINE NORM + ! Differentiation of gethyptandist in reverse (adjoint) mode: ! gradient of useful results: spacings ! with respect to varying inputs: sp1 sp2 @@ -622,29 +637,27 @@ SUBROUTINE GETHYPTANDIST_B(sp1, sp1b, sp2, sp2b, n, spacings, & INTRINSIC SQRT INTRINSIC FLOAT INTRINSIC TANH + REAL(kind=realtype) :: abs0 REAL(kind=realtype) :: arg1 REAL(kind=realtype) :: arg1b + REAL(kind=realtype) :: temp + REAL(kind=realtype) :: tempb INTEGER :: ad_count INTEGER :: i0 INTEGER :: branch - REAL(kind=realtype) :: temp0 - REAL(kind=realtype) :: tempb0 - REAL(kind=realtype) :: tempb - REAL(kind=realtype) :: abs0 - REAL(kind=realtype) :: temp ! Manually created secant method for the above solve b = 4. step = 1.e-6 ad_count = 1 DO i=1,1000 - CALL PUSHREAL4ARRAY(b_out, realtype/4) + CALL PUSHREAL8(b_out) CALL FINDROOTB(b, sp1, sp2, n, b_out) arg1 = b - step CALL FINDROOTB(arg1, sp1, sp2, n, b_out_step) b_old = b - CALL PUSHREAL4ARRAY(f_prime, realtype/4) + CALL PUSHREAL8(f_prime) f_prime = (b_out-b_out_step)/step - CALL PUSHREAL4ARRAY(b, realtype/4) + CALL PUSHREAL8(b) b = b - b_out/f_prime IF (b_old - b .GE. 0.) THEN abs0 = b_old - b @@ -665,29 +678,29 @@ SUBROUTINE GETHYPTANDIST_B(sp1, sp1b, sp2, sp2b, n, spacings, & ! Compute parameter A 110 a = SQRT(sp1/sp2) DO i=1,n - CALL PUSHREAL4ARRAY(r, realtype/4) + CALL PUSHREAL8(r) r = FLOAT(i-1)/FLOAT(n-1) - .5 - CALL PUSHREAL4ARRAY(u, realtype/4) + CALL PUSHREAL8(u) u = 1 + TANH(b*r)/TANH(b/2) END DO - ab = 0.0 - bb = 0.0 + ab = 0.0_8 + bb = 0.0_8 DO i=n,1,-1 - temp0 = 2*a + (-a+1)*u - tempb0 = -(u*spacingsb(i)/temp0**2) - ub = (1-a)*tempb0 + spacingsb(i)/temp0 - ab = ab + (2-u)*tempb0 - spacingsb(i) = 0.0 - CALL POPREAL4ARRAY(u, realtype/4) + temp = 2*a + (-a+1)*u + tempb = -(u*spacingsb(i)/temp**2) + ub = spacingsb(i)/temp + (1-a)*tempb + spacingsb(i) = 0.0_8 + ab = ab + (2-u)*tempb + CALL POPREAL8(u) temp = TANH(b/2) - bb = bb + ((1.0-TANH(r*b)**2)*r/temp-(1.0-TANH(b/2)**2)*TANH(r*b)/& -& (temp**2*2))*ub - CALL POPREAL4ARRAY(r, realtype/4) + bb = bb + (r*(1.0-TANH(r*b)**2)/temp-(1.0-TANH(b/2)**2)*TANH(r*b)/& +& (2*temp**2))*ub + CALL POPREAL8(r) END DO IF (sp1/sp2 .EQ. 0.0) THEN - tempb = 0.0 + tempb = 0.0_8 ELSE - tempb = ab/(2.0*SQRT(sp1/sp2)*sp2) + tempb = ab/(sp2*2.0*SQRT(sp1/sp2)) END IF sp1b = tempb sp2b = -(sp1*tempb/sp2) @@ -698,19 +711,20 @@ SUBROUTINE GETHYPTANDIST_B(sp1, sp1b, sp2, sp2b, n, spacings, & IF (branch .EQ. 0) GOTO 120 END IF f_primeb = b_out*bb/f_prime**2 - CALL POPREAL4ARRAY(b, realtype/4) + CALL POPREAL8(b) b_outb = f_primeb/step - bb/f_prime - CALL POPREAL4ARRAY(f_prime, realtype/4) + CALL POPREAL8(f_prime) b_out_stepb = -(f_primeb/step) arg1 = b - step - arg1b = 0.0 + arg1b = 0.0_8 CALL FINDROOTB_B(arg1, arg1b, sp1, sp1b, sp2, sp2b, n, b_out_step& & , b_out_stepb) bb = bb + arg1b - CALL POPREAL4ARRAY(b_out, realtype/4) + CALL POPREAL8(b_out) CALL FINDROOTB_B(b, bb, sp1, sp1b, sp2, sp2b, n, b_out, b_outb) 120 CONTINUE END SUBROUTINE GETHYPTANDIST_B + SUBROUTINE GETHYPTANDIST(sp1, sp2, n, spacings) IMPLICIT NONE REAL(kind=realtype), INTENT(IN) :: sp1, sp2 @@ -723,8 +737,8 @@ SUBROUTINE GETHYPTANDIST(sp1, sp2, n, spacings) INTRINSIC SQRT INTRINSIC FLOAT INTRINSIC TANH - REAL(kind=realtype) :: arg1 REAL(kind=realtype) :: abs0 + REAL(kind=realtype) :: arg1 ! Manually created secant method for the above solve b = 4. step = 1.e-6 @@ -750,6 +764,7 @@ SUBROUTINE GETHYPTANDIST(sp1, sp2, n, spacings) spacings(i) = u/(2*a+(1-a)*u) END DO END SUBROUTINE GETHYPTANDIST + ! Differentiation of findrootb in reverse (adjoint) mode: ! gradient of useful results: b_out sp1 sp2 b ! with respect to varying inputs: sp1 sp2 b @@ -762,20 +777,21 @@ SUBROUTINE FINDROOTB_B(b, bb, sp1, sp1b, sp2, sp2b, n, b_out, b_outb) REAL(kind=realtype) :: b_outb INTRINSIC SINH INTRINSIC SQRT - REAL(kind=realtype) :: tempb0 - REAL(kind=realtype) :: tempb REAL(kind=realtype) :: temp + REAL(kind=realtype) :: tempb + REAL(kind=realtype) :: tempb0 temp = SQRT(sp1*sp2) tempb = -(b_outb/((n-1)*temp)) + bb = bb + COSH(b)*b_outb + tempb IF (sp1*sp2 .EQ. 0.0) THEN - tempb0 = 0.0 + tempb0 = 0.0_8 ELSE - tempb0 = -(b*tempb/(temp**2*2.0)) + tempb0 = -(b*tempb/(2.0*temp**2)) END IF - bb = bb + tempb + COSH(b)*b_outb sp1b = sp1b + sp2*tempb0 sp2b = sp2b + sp1*tempb0 END SUBROUTINE FINDROOTB_B + SUBROUTINE FINDROOTB(b, sp1, sp2, n, b_out) IMPLICIT NONE REAL(kind=realtype), INTENT(IN) :: b, sp1, sp2 @@ -785,6 +801,7 @@ SUBROUTINE FINDROOTB(b, sp1, sp2, n, b_out) INTRINSIC SQRT b_out = SINH(b) - b/(n-1)/SQRT(sp1*sp2) END SUBROUTINE FINDROOTB + !============================================================ ! BOUNDING BOX ROUTINES !============================================================ @@ -801,6 +818,7 @@ SUBROUTINE COMPUTEBBOX(coor, bbox) bbox(:, 1) = MINVAL(coor, 2) bbox(:, 2) = MAXVAL(coor, 2) END SUBROUTINE COMPUTEBBOX + !============================================================ SUBROUTINE COMPUTEBBOXPERELEMENTS(nnodes, ntria, nquads, coor, & & triaconn, quadsconn, triabbox, quadsbbox) @@ -850,6 +868,7 @@ SUBROUTINE COMPUTEBBOXPERELEMENTS(nnodes, ntria, nquads, coor, & quadsbbox(4:6, elemid) = MAXVAL(arg10(:, :), 2) END DO END SUBROUTINE COMPUTEBBOXPERELEMENTS + !============================================================ SUBROUTINE COMPUTEBBOXINTERSECTION(bboxa, bboxb, bboxab, overlap) IMPLICIT NONE @@ -871,10 +890,11 @@ SUBROUTINE COMPUTEBBOXINTERSECTION(bboxa, bboxb, bboxab, overlap) ! Y overlap CALL LINEINTERSECTIONINTERVAL(bboxa(2), bboxa(5), bboxb(2), bboxb(& & 5), bboxab(2), bboxab(5), overlap) - IF (overlap) CALL LINEINTERSECTIONINTERVAL(bboxa(3), bboxa(6), & -& bboxb(3), bboxb(6), bboxab(3)& -& , bboxab(6), overlap) + IF (overlap) THEN ! Z overlap + CALL LINEINTERSECTIONINTERVAL(bboxa(3), bboxa(6), bboxb(3), & +& bboxb(6), bboxab(3), bboxab(6), overlap) + END IF END IF ! Determine the size of the edges of the bounding box bounds(1) = bboxab(4) - bboxab(1) @@ -888,6 +908,7 @@ SUBROUTINE COMPUTEBBOXINTERSECTION(bboxa, bboxb, bboxab, overlap) ! bounding box. bboxab = bboxab - 0.01*bounds END SUBROUTINE COMPUTEBBOXINTERSECTION + !============================================================ SUBROUTINE LINEINTERSECTIONINTERVAL(xmina, xmaxa, xminb, xmaxb, xminab& & , xmaxab, overlap) @@ -916,4 +937,6 @@ SUBROUTINE LINEINTERSECTIONINTERVAL(xmina, xmaxa, xminb, xmaxb, xminab& overlap = .true. END IF END SUBROUTINE LINEINTERSECTIONINTERVAL + END MODULE UTILITIES_B + diff --git a/src/adjoint/utilities_d.f90 b/src/adjoint/utilities_d.f90 index 43a0756..b7156d6 100644 --- a/src/adjoint/utilities_d.f90 +++ b/src/adjoint/utilities_d.f90 @@ -1,5 +1,5 @@ -! Generated by TAPENADE (INRIA, Tropics team) -! Tapenade 3.10 (r5363) - 9 Sep 2014 09:53 +! Generated by TAPENADE (INRIA, Ecuador team) +! Tapenade 3.16 (master) - 9 Oct 2020 17:47 ! MODULE UTILITIES_D USE PRECISION @@ -98,6 +98,7 @@ SUBROUTINE CONDENSEBARNODES_MAIN(nnodes, nelem, disttol, coor, & barsconn(2, elemid) = linkold2new(barsconn(2, elemid)) END DO END SUBROUTINE CONDENSEBARNODES_MAIN + ! Differentiation of remesh_main in forward (tangent) mode: ! variations of useful results: newcoor ! with respect to varying inputs: coor @@ -116,7 +117,7 @@ SUBROUTINE REMESH_MAIN_D(nnodes, nelem, nnewnodes, coor, coord, & ! Output variables REAL(kind=realtype), DIMENSION(3, nnewnodes) :: newcoor REAL(kind=realtype), DIMENSION(3, nnewnodes) :: newcoord - INTEGER(kind=inttype), DIMENSION(2, nnewnodes - 1) :: newbarsconn + INTEGER(kind=inttype), DIMENSION(2, nnewnodes-1) :: newbarsconn ! Working variables REAL(kind=realtype), DIMENSION(3, nnodes) :: nodecoor REAL(kind=realtype), DIMENSION(3, nnodes) :: nodecoord @@ -133,6 +134,8 @@ SUBROUTINE REMESH_MAIN_D(nnodes, nelem, nnewnodes, coor, coord, & INTRINSIC COS INTRINSIC SQRT REAL(kind=realtype) :: arg1 + REAL(kind=realtype) :: temp + REAL(kind=realtype) :: temp0 ! Tolerance to avoid any interpolation if new node is too close to an original node disttol = 1e-7 nnodes = nelem + 1 @@ -151,11 +154,11 @@ SUBROUTINE REMESH_MAIN_D(nnodes, nelem, nnewnodes, coor, coord, & ! We can proceed if FE data is ordered ! Store position of the first node (the other nodes will be covered in the loop) ! (the -1 is due Fortran indexing) - nodecoord = 0.0 + nodecoord = 0.0_8 nodecoord(:, 1) = coord(:, barsconn(1, 1)) nodecoor(:, 1) = coor(:, barsconn(1, 1)) arclength(1) = 0.0 - arclengthd = 0.0 + arclengthd = 0.0_8 ! Loop over each element to increment arcLength DO elemid=1,nelem ! Get node positions (the -1 is due Fortran indexing) @@ -182,27 +185,29 @@ SUBROUTINE REMESH_MAIN_D(nnodes, nelem, nnewnodes, coor, coord, & ! [0.0, 1.0]. We will rescale it after the if statements. IF (spacing .EQ. 'linear') THEN CALL LINSPACE(zero, one, nnewnodes, newarclength) - newarclengthd = 0.0 + newarclengthd = 0.0_8 ELSE IF (spacing .EQ. 'cosine') THEN CALL LINSPACE(zero, pi, nnewnodes, newarclength) newarclength = 0.5*(1.0-COS(newarclength)) - newarclengthd = 0.0 + newarclengthd = 0.0_8 ELSE IF (spacing .EQ. 'hyptan') THEN - CALL GETHYPTANDIST_D(sp1/arclength(nelem+1), -(sp1*arclengthd(& -& nelem+1)/arclength(nelem+1)**2), sp2/arclength(& -& nelem+1), -(sp2*arclengthd(nelem+1)/arclength(nelem& -& +1)**2), nnewnodes, newarclength, newarclengthd) + temp = sp2/arclength(nelem+1) + temp0 = sp1/arclength(nelem+1) + CALL GETHYPTANDIST_D(sp1/arclength(nelem+1), -(temp0*arclengthd(& +& nelem+1)/arclength(nelem+1)), sp2/arclength(nelem+1& +& ), -(temp*arclengthd(nelem+1)/arclength(nelem+1)), & +& nnewnodes, newarclength, newarclengthd) ELSE - newarclengthd = 0.0 + newarclengthd = 0.0_8 END IF ! Rescale newArcLength based on the final distance - newarclengthd = arclengthd(nnodes)*newarclength + arclength(nnodes)*& + newarclengthd = newarclength*arclengthd(nnodes) + arclength(nnodes)*& & newarclengthd newarclength = arclength(nnodes)*newarclength ! INTERPOLATE NEW NODES ! Now we sample the new coordinates based on the interpolation method given by the user ! Create interpolants for x, y, and z - newcoord = 0.0 + newcoord = 0.0_8 CALL INTERP1D_D(1, nnodes, arclength, arclengthd, nodecoor(1, :), & & nodecoord(1, :), nnewnodes, newarclength, newarclengthd, & & newcoor(1, :), newcoord(1, :)) @@ -251,10 +256,11 @@ SUBROUTINE REMESH_MAIN_D(nnodes, nelem, nnewnodes, coor, coord, & 100 PRINT*, & & 'WARNING: Could not remesh curve because it has unordered FE data.' PRINT*, ' Call FEsort first.' - newcoord = 0.0 + newcoord = 0.0_8 RETURN 110 CONTINUE END SUBROUTINE REMESH_MAIN_D + SUBROUTINE REMESH_MAIN(nnodes, nelem, nnewnodes, coor, barsconn, & & method, spacing, sp1, sp2, newcoor, newbarsconn) IMPLICIT NONE @@ -267,7 +273,7 @@ SUBROUTINE REMESH_MAIN(nnodes, nelem, nnewnodes, coor, barsconn, & REAL(kind=realtype), INTENT(IN) :: sp1, sp2 ! Output variables REAL(kind=realtype), DIMENSION(3, nnewnodes) :: newcoor - INTEGER(kind=inttype), DIMENSION(2, nnewnodes - 1) :: newbarsconn + INTEGER(kind=inttype), DIMENSION(2, nnewnodes-1) :: newbarsconn ! Working variables REAL(kind=realtype), DIMENSION(3, nnodes) :: nodecoor REAL(kind=realtype), DIMENSION(nnodes) :: arclength @@ -372,11 +378,14 @@ SUBROUTINE REMESH_MAIN(nnodes, nelem, nnewnodes, coor, barsconn, & arg1 = distvec(1)**2 + distvec(2)**2 + distvec(3)**2 dist = SQRT(arg1) ! Check if distance is below a threshold - IF (dist .LT. disttol) newcoor(:, ii) = nodecoor(:, jj) + IF (dist .LT. disttol) THEN ! Repeat the old node to avoid indetermination in derivatives + newcoor(:, ii) = nodecoor(:, jj) + END IF END DO END DO END SUBROUTINE REMESH_MAIN + !============================================================ SUBROUTINE LINSPACE(l, k, n, z) IMPLICIT NONE @@ -397,6 +406,7 @@ SUBROUTINE LINSPACE(l, k, n, z) z(n) = k RETURN END SUBROUTINE LINSPACE + ! Differentiation of interp1d in forward (tangent) mode: ! variations of useful results: p_interp ! with respect to varying inputs: p_interp p_data t_data t_interp @@ -419,6 +429,7 @@ SUBROUTINE INTERP1D_D(m, data_num, t_data, t_datad, p_data, p_datad, & REAL(kind=realtype) :: t_datad(data_num) REAL(kind=realtype) :: t_interp(interp_num) REAL(kind=realtype) :: t_interpd(interp_num) + REAL(kind=realtype) :: temp DO interp=1,interp_num td = t_interpd(interp) t = t_interp(interp) @@ -427,16 +438,17 @@ SUBROUTINE INTERP1D_D(m, data_num, t_data, t_datad, p_data, p_datad, & ! nearest to, TVAL. ! CALL R8VEC_BRACKET(data_num, t_data, t, left, right) - p_interpd(interp) = (((t_datad(right)-td)*p_data(left)+(t_data(& -& right)-t)*p_datad(left)+(td-t_datad(left))*p_data(right)+(t-& -& t_data(left))*p_datad(right))*(t_data(right)-t_data(left))-((& -& t_data(right)-t)*p_data(left)+(t-t_data(left))*p_data(right))*(& -& t_datad(right)-t_datad(left)))/(t_data(right)-t_data(left))**2 - p_interp(interp) = ((t_data(right)-t)*p_data(left)+(t-t_data(left)& -& )*p_data(right))/(t_data(right)-t_data(left)) + temp = ((t_data(right)-t)*p_data(left)+(t-t_data(left))*p_data(& +& right))/(t_data(right)-t_data(left)) + p_interpd(interp) = (p_data(left)*(t_datad(right)-td)+(t_data(& +& right)-t)*p_datad(left)+p_data(right)*(td-t_datad(left))+(t-& +& t_data(left))*p_datad(right)-temp*(t_datad(right)-t_datad(left))& +& )/(t_data(right)-t_data(left)) + p_interp(interp) = temp END DO RETURN END SUBROUTINE INTERP1D_D + SUBROUTINE INTERP1D(m, data_num, t_data, p_data, interp_num, t_interp& & , p_interp) IMPLICIT NONE @@ -463,6 +475,7 @@ SUBROUTINE INTERP1D(m, data_num, t_data, p_data, interp_num, t_interp& END DO RETURN END SUBROUTINE INTERP1D + SUBROUTINE R8VEC_BRACKET(n, x, xval, left, right) IMPLICIT NONE INTEGER(kind=inttype) :: n @@ -482,6 +495,7 @@ SUBROUTINE R8VEC_BRACKET(n, x, xval, left, right) right = n RETURN END SUBROUTINE R8VEC_BRACKET + ! Differentiation of dot in forward (tangent) mode: ! variations of useful results: dot_ ! with respect to varying inputs: a b @@ -493,9 +507,10 @@ SUBROUTINE DOT_D0(a, ad, b, bd, dot_, dot_d) REAL(kind=realtype), INTENT(OUT) :: dot_ REAL(kind=realtype), INTENT(OUT) :: dot_d INTRINSIC SUM - dot_d = SUM(ad*b + a*bd) + dot_d = SUM(b*ad + a*bd) dot_ = SUM(a*b) END SUBROUTINE DOT_D0 + !============================================================ SUBROUTINE DOT(a, b, dot_) IMPLICIT NONE @@ -504,6 +519,7 @@ SUBROUTINE DOT(a, b, dot_) INTRINSIC SUM dot_ = SUM(a*b) END SUBROUTINE DOT + ! Differentiation of norm in forward (tangent) mode: ! variations of useful results: norm_ ! with respect to varying inputs: a @@ -517,16 +533,18 @@ SUBROUTINE NORM_D0(a, ad, norm_, norm_d) INTRINSIC SQRT REAL(kind=realtype) :: arg1 REAL(kind=realtype) :: arg1d - arg1d = ad(1)*a(1) + a(1)*ad(1) + ad(2)*a(2) + a(2)*ad(2) + ad(3)*a(& -& 3) + a(3)*ad(3) + REAL(kind=realtype) :: temp + arg1d = 2*a(1)*ad(1) + 2*a(2)*ad(2) + 2*a(3)*ad(3) arg1 = a(1)*a(1) + a(2)*a(2) + a(3)*a(3) + temp = SQRT(arg1) IF (arg1 .EQ. 0.0) THEN - norm_d = 0.0 + norm_d = 0.0_8 ELSE - norm_d = arg1d/(2.0*SQRT(arg1)) + norm_d = arg1d/(2.0*temp) END IF - norm_ = SQRT(arg1) + norm_ = temp END SUBROUTINE NORM_D0 + !============================================================ SUBROUTINE NORM(a, norm_) IMPLICIT NONE @@ -537,6 +555,7 @@ SUBROUTINE NORM(a, norm_) arg1 = a(1)*a(1) + a(2)*a(2) + a(3)*a(3) norm_ = SQRT(arg1) END SUBROUTINE NORM + ! Differentiation of gethyptandist in forward (tangent) mode: ! variations of useful results: spacings ! with respect to varying inputs: sp1 sp2 @@ -558,10 +577,12 @@ SUBROUTINE GETHYPTANDIST_D(sp1, sp1d, sp2, sp2d, n, spacings, & INTRINSIC FLOAT INTRINSIC TANH REAL(kind=realtype) :: abs0 + REAL(kind=realtype) :: temp + REAL(kind=realtype) :: temp0 ! Manually created secant method for the above solve b = 4. step = 1.e-6 - bd = 0.0 + bd = 0.0_8 DO i=1,1000 CALL FINDROOTB_D(b, bd, sp1, sp1d, sp2, sp2d, n, b_out, b_outd) CALL FINDROOTB_D(b - step, bd, sp1, sp1d, sp2, sp2d, n, b_out_step& @@ -569,33 +590,37 @@ SUBROUTINE GETHYPTANDIST_D(sp1, sp1d, sp2, sp2d, n, spacings, & b_old = b f_primed = (b_outd-b_out_stepd)/step f_prime = (b_out-b_out_step)/step - bd = bd - (b_outd*f_prime-b_out*f_primed)/f_prime**2 + bd = bd - (b_outd-b_out*f_primed/f_prime)/f_prime b = b - b_out/f_prime IF (b_old - b .GE. 0.) THEN abs0 = b_old - b ELSE abs0 = -(b_old-b) END IF - IF (abs0 .LT. 1.e-10) GOTO 100 + IF (abs0 .LT. 1.e-10) EXIT END DO ! Compute parameter A - 100 IF (sp1/sp2 .EQ. 0.0) THEN - ad = 0.0 + temp = sp1/sp2 + temp0 = SQRT(temp) + IF (temp .EQ. 0.0) THEN + ad = 0.0_8 ELSE - ad = (sp1d*sp2-sp1*sp2d)/(sp2**2*2.0*SQRT(sp1/sp2)) + ad = (sp1d-temp*sp2d)/(2.0*temp0*sp2) END IF - a = SQRT(sp1/sp2) - spacingsd = 0.0 + a = temp0 + spacingsd = 0.0_8 DO i=1,n r = FLOAT(i-1)/FLOAT(n-1) - .5 - ud = (r*bd*(1.0-TANH(b*r)**2)*TANH(b/2)-TANH(b*r)*bd*(1.0-TANH(b/2& -& )**2)/2)/TANH(b/2)**2 - u = 1 + TANH(b*r)/TANH(b/2) - spacingsd(i) = (ud*(2*a+(1-a)*u)-u*(2*ad+(1-a)*ud-ad*u))/(2*a+(1-a& -& )*u)**2 - spacings(i) = u/(2*a+(1-a)*u) + temp0 = TANH(b/2) + temp = TANH(r*b)/temp0 + ud = ((1.0-TANH(r*b)**2)*r-temp*(1.0-TANH(b/2)**2)/2)*bd/temp0 + u = temp + 1 + temp0 = 2*a + (-a+1)*u + spacingsd(i) = (ud-u*((2-u)*ad+(1-a)*ud)/temp0)/temp0 + spacings(i) = u/temp0 END DO END SUBROUTINE GETHYPTANDIST_D + SUBROUTINE GETHYPTANDIST(sp1, sp2, n, spacings) IMPLICIT NONE REAL(kind=realtype), INTENT(IN) :: sp1, sp2 @@ -633,6 +658,7 @@ SUBROUTINE GETHYPTANDIST(sp1, sp2, n, spacings) spacings(i) = u/(2*a+(1-a)*u) END DO END SUBROUTINE GETHYPTANDIST + ! Differentiation of findrootb in forward (tangent) mode: ! variations of useful results: b_out ! with respect to varying inputs: sp1 sp2 b @@ -649,17 +675,21 @@ SUBROUTINE FINDROOTB_D(b, bd, sp1, sp1d, sp2, sp2d, n, b_out, b_outd) REAL(kind=realtype) :: arg1d REAL(kind=realtype) :: result1 REAL(kind=realtype) :: result1d - arg1d = sp1d*sp2 + sp1*sp2d + REAL(kind=realtype) :: temp + arg1d = sp2*sp1d + sp1*sp2d arg1 = sp1*sp2 + temp = SQRT(arg1) IF (arg1 .EQ. 0.0) THEN - result1d = 0.0 + result1d = 0.0_8 ELSE - result1d = arg1d/(2.0*SQRT(arg1)) + result1d = arg1d/(2.0*temp) END IF - result1 = SQRT(arg1) - b_outd = bd*COSH(b) - (bd*result1/(n-1)-b*result1d/(n-1))/result1**2 - b_out = SINH(b) - b/(n-1)/result1 + result1 = temp + temp = b/((n-1)*result1) + b_outd = COSH(b)*bd - (bd-temp*(n-1)*result1d)/((n-1)*result1) + b_out = SINH(b) - temp END SUBROUTINE FINDROOTB_D + SUBROUTINE FINDROOTB(b, sp1, sp2, n, b_out) IMPLICIT NONE REAL(kind=realtype), INTENT(IN) :: b, sp1, sp2 @@ -673,6 +703,7 @@ SUBROUTINE FINDROOTB(b, sp1, sp2, n, b_out) result1 = SQRT(arg1) b_out = SINH(b) - b/(n-1)/result1 END SUBROUTINE FINDROOTB + !============================================================ ! BOUNDING BOX ROUTINES !============================================================ @@ -689,6 +720,7 @@ SUBROUTINE COMPUTEBBOX(coor, bbox) bbox(:, 1) = MINVAL(coor, 2) bbox(:, 2) = MAXVAL(coor, 2) END SUBROUTINE COMPUTEBBOX + !============================================================ SUBROUTINE COMPUTEBBOXPERELEMENTS(nnodes, ntria, nquads, coor, & & triaconn, quadsconn, triabbox, quadsbbox) @@ -738,6 +770,7 @@ SUBROUTINE COMPUTEBBOXPERELEMENTS(nnodes, ntria, nquads, coor, & quadsbbox(4:6, elemid) = MAXVAL(arg10(:, :), 2) END DO END SUBROUTINE COMPUTEBBOXPERELEMENTS + !============================================================ SUBROUTINE COMPUTEBBOXINTERSECTION(bboxa, bboxb, bboxab, overlap) IMPLICIT NONE @@ -759,10 +792,11 @@ SUBROUTINE COMPUTEBBOXINTERSECTION(bboxa, bboxb, bboxab, overlap) ! Y overlap CALL LINEINTERSECTIONINTERVAL(bboxa(2), bboxa(5), bboxb(2), bboxb(& & 5), bboxab(2), bboxab(5), overlap) - IF (overlap) CALL LINEINTERSECTIONINTERVAL(bboxa(3), bboxa(6), & -& bboxb(3), bboxb(6), bboxab(3)& -& , bboxab(6), overlap) + IF (overlap) THEN ! Z overlap + CALL LINEINTERSECTIONINTERVAL(bboxa(3), bboxa(6), bboxb(3), & +& bboxb(6), bboxab(3), bboxab(6), overlap) + END IF END IF ! Determine the size of the edges of the bounding box bounds(1) = bboxab(4) - bboxab(1) @@ -776,6 +810,7 @@ SUBROUTINE COMPUTEBBOXINTERSECTION(bboxa, bboxb, bboxab, overlap) ! bounding box. bboxab = bboxab - 0.01*bounds END SUBROUTINE COMPUTEBBOXINTERSECTION + !============================================================ SUBROUTINE LINEINTERSECTIONINTERVAL(xmina, xmaxa, xminb, xmaxb, xminab& & , xmaxab, overlap) @@ -804,4 +839,6 @@ SUBROUTINE LINEINTERSECTIONINTERVAL(xmina, xmaxa, xminb, xmaxb, xminab& overlap = .true. END IF END SUBROUTINE LINEINTERSECTIONINTERVAL + END MODULE UTILITIES_D + diff --git a/src/common/complexify.f90 b/src/common/complexify.f90 index e219d81..83fc7ae 100644 --- a/src/common/complexify.f90 +++ b/src/common/complexify.f90 @@ -1,4 +1,3 @@ -!****************************************************************************** ! Written for 'complexify.py 1.3' ! J.R.R.A.Martins 1999 ! 21-Apr-00 Fixed tan, sinh, cosh @@ -14,7 +13,6 @@ ! _ci and _ic cominations to the relational operators. ! P. Sturdza ! -!****************************************************************************** ! ! Assume all code is compiled with double precision (-r8 compiler flag) ! @@ -86,9 +84,20 @@ module complexify module procedure min_cccc end interface +! MINVAL + interface minval + module procedure minval_c + end interface minval + +! MAXVAL + interface maxval + module procedure maxval_c + end interface maxval + ! SIGN interface sign module procedure sign_cc + module procedure sign_cca module procedure sign_cr module procedure sign_rc end interface @@ -155,6 +164,8 @@ module complexify module procedure gt_rc module procedure gt_ci module procedure gt_ic + module procedure gt_cac + module procedure gt_car end interface !! MIPSpro Compilers: Version 7.30 won't take .ge. and .eq.. @@ -200,6 +211,10 @@ module complexify module procedure eq_cc module procedure eq_rr module procedure eq_ii + module procedure eq_iai + module procedure eq_iaia + module procedure eq_i8i8 + module procedure eq_i1i1 module procedure eq_aa module procedure eq_cr module procedure eq_rc @@ -230,37 +245,40 @@ module complexify module procedure ne_ri end interface +! floor + interface floor + module procedure floor_c + end interface + contains -!****************************************************************************** ! ! Function definitions ! -!****************************************************************************** ! ABS, intrinsic - complex * 16 function abs_c(val) - complex*16, intent(in) :: val + complex(kind=8) function abs_c(val) + complex(kind=8), intent(in) :: val abs_c = val if (real(val) < 0) abs_c = cmplx(-real(val), -aimag(val)) return end function abs_c ! COSD -! complex*16 function cosd_c(z) -! complex*16, intent(in) :: z +! complex(kind=8) function cosd_c(z) +! complex(kind=8), intent(in) :: z ! cosd_c = cos(z*3.14159265358979323846/180.) ! end function cosd_c ! SIND -! complex*16 function sind_c(z) -! complex*16, intent(in) :: z +! complex(kind=8) function sind_c(z) +! complex(kind=8), intent(in) :: z ! sind_c = sin(z*3.14159265358979323846/180.) ! end function sind_c ! ACOS - complex * 16 function acos_c(z) - complex*16, intent(in) :: z + complex(kind=8) function acos_c(z) + complex(kind=8), intent(in) :: z ! acos_c = - cmplx(0., 1.)*log(z+sqrt(z**2-1.)) ! not general complex valued formula: acos_c = cmplx(acos(real(z)), -aimag(z) / sqrt(1.-real(z)**2)) @@ -268,8 +286,8 @@ complex * 16 function acos_c(z) end function acos_c ! ASIN - complex * 16 function asin_c(z) - complex*16, intent(in) :: z + complex(kind=8) function asin_c(z) + complex(kind=8), intent(in) :: z ! asin_c = - cmplx(0., 1.)*log(cmplx(0.,1.)*z+sqrt(1.-z**2)) ! not general complex valued formula: asin_c = cmplx(asin(real(z)), aimag(z) / sqrt(1.-real(z)**2)) @@ -277,10 +295,10 @@ complex * 16 function asin_c(z) end function asin_c ! ATAN - complex * 16 function atan_c(z) - complex*16, intent(in) :: z -! complex*16 z2 -! real*8 pi2, xans, yans, r, r2, x, y + complex(kind=8) function atan_c(z) + complex(kind=8), intent(in) :: z +! complex(kind=8) z2 +! real(kind=8) pi2, xans, yans, r, r2, x, y ! pi2 = 2.0*atan(1.0) ! r = sqrt(real(z)**2+aimag(z)**2) ! x = real(z) @@ -295,9 +313,9 @@ complex * 16 function atan_c(z) end function atan_c ! ATAN2 - complex * 16 function atan2_cc(csn, ccs) - complex*16, intent(in) :: csn, ccs -! real*8 pi + complex(kind=8) function atan2_cc(csn, ccs) + complex(kind=8), intent(in) :: csn, ccs +! real(kind=8) pi ! pi = 4.0*atan(1.0) ! if (sqrt(real(ccs)**2 + aimag(ccs)**2).eq.0.) then ! abs orig ! if (sqrt(real(csn)**2+aimag(csn)**2).eq.0.) then @@ -311,7 +329,7 @@ complex * 16 function atan2_cc(csn, ccs) ! if (real(atan2_cc).gt.pi) atan2_cc = atan2_cc - 2.0*pi ! end if ! not general complex valued formula: - real * 8 a, b, c, d + real(kind=8) a, b, c, d a = real(csn) b = aimag(csn) c = real(ccs) @@ -321,9 +339,9 @@ complex * 16 function atan2_cc(csn, ccs) end function atan2_cc ! COSH - complex * 16 function cosh_c(z) - complex*16, intent(in) :: z -! complex*16 eplus, eminus + complex(kind=8) function cosh_c(z) + complex(kind=8), intent(in) :: z +! complex(kind=8) eplus, eminus ! eplus = exp(z) ! eminus = exp(z) ! cosh_c = (eplus + eminus)/2. @@ -333,9 +351,9 @@ complex * 16 function cosh_c(z) end function cosh_c ! SINH - complex * 16 function sinh_c(z) - complex*16, intent(in) :: z -! complex*16 eplus, eminus + complex(kind=8) function sinh_c(z) + complex(kind=8), intent(in) :: z +! complex(kind=8) eplus, eminus ! eplus = exp(z) ! eminus = exp(z) ! sinh_c = (eplus - eminus)/2. @@ -345,9 +363,9 @@ complex * 16 function sinh_c(z) end function sinh_c ! TAN - complex * 16 function tan_c(z) - complex*16, intent(in) :: z -! complex*16 eiplus, eiminus + complex(kind=8) function tan_c(z) + complex(kind=8), intent(in) :: z +! complex(kind=8) eiplus, eiminus ! eiplus = exp(cmplx(0.,1.)*z) ! eiminus = exp(-cmplx(0.,1.)*z) ! tan_c = cmplx(0.,1.)*(eiminus - eiplus)/(eiplus + eiminus) @@ -357,9 +375,9 @@ complex * 16 function tan_c(z) end function tan_c ! TANH - complex * 16 function tanh_c(a) - complex*16, intent(in) :: a -! complex*16 eplus, eminus + complex(kind=8) function tanh_c(a) + complex(kind=8), intent(in) :: a +! complex(kind=8) eplus, eminus ! if(real(a) > 50)then ! tanh_c = 1. ! else @@ -371,136 +389,164 @@ complex * 16 function tanh_c(a) tanh_c = cmplx(tanh(real(a)), aimag(a) / cosh(real(a))**2) return end function tanh_c - ! MAX, intrinsic - complex * 16 function max_cc(val1, val2) - complex*16, intent(in) :: val1, val2 - if (real(val1) > real(val2)) then - max_cc = val1 - else +! the logical statements here are chosen to match fwd AD code from tapenade +! this way they are consistent even when the real parts are equal + complex(kind=8) function max_cc(val1, val2) + complex(kind=8), intent(in) :: val1, val2 + if (real(val1) < real(val2)) then max_cc = val2 + else + max_cc = val1 end if return end function max_cc - complex * 16 function max_cr(val1, val2) - complex*16, intent(in) :: val1 - real*8, intent(in) :: val2 - if (real(val1) > val2) then - max_cr = val1 - else + complex(kind=8) function max_cr(val1, val2) + complex(kind=8), intent(in) :: val1 + real(kind=8), intent(in) :: val2 + if (real(val1) < val2) then max_cr = cmplx(val2, 0.) + else + max_cr = val1 end if return end function max_cr - complex * 16 function max_rc(val1, val2) - real*8, intent(in) :: val1 - complex*16, intent(in) :: val2 - if (val1 > real(val2)) then - max_rc = cmplx(val1, 0.) - else + complex(kind=8) function max_rc(val1, val2) + real(kind=8), intent(in) :: val1 + complex(kind=8), intent(in) :: val2 + if (val1 < real(val2)) then max_rc = val2 + else + max_rc = cmplx(val1, 0.) end if return end function max_rc - complex * 16 function max_ccc(val1, val2, val3) - complex*16, intent(in) :: val1, val2, val3 - if (real(val1) > real(val2)) then - max_ccc = val1 - else + complex(kind=8) function max_ccc(val1, val2, val3) + complex(kind=8), intent(in) :: val1, val2, val3 + if (real(val1) < real(val2)) then max_ccc = val2 + else + max_ccc = val1 end if - if (real(val3) > real(max_ccc)) then + + if (real(max_ccc) < real(val3)) then max_ccc = val3 end if return end function max_ccc function max_cccc(val1, val2, val3, val4) - complex*16, intent(in) :: val1, val2, val3, val4 - complex * 16 max_cccc - complex * 16 max_cccc2 - if (real(val1) > real(val2)) then - max_cccc = val1 - else + complex(kind=8), intent(in) :: val1, val2, val3, val4 + complex(kind=8) max_cccc + complex(kind=8) max_cccc2 + if (real(val1) < real(val2)) then max_cccc = val2 - end if - if (real(val3) > real(val4)) then - max_cccc2 = val3 else + max_cccc = val1 + end if + if (real(val3) < real(val4)) then max_cccc2 = val4 + else + max_cccc2 = val3 end if - if (real(max_cccc2) > real(max_cccc)) then + if (real(max_cccc) < real(max_cccc2)) then max_cccc = max_cccc2 end if return end function max_cccc ! MIN, intrinsic - complex * 16 function min_cc(val1, val2) - complex*16, intent(in) :: val1, val2 - if (real(val1) < real(val2)) then - min_cc = val1 - else +! the logical statements here are chosen to match fwd AD code from tapenade +! this way they are consistent even when the real parts are equal + complex(kind=8) function min_cc(val1, val2) + complex(kind=8), intent(in) :: val1, val2 + if (real(val1) > real(val2)) then min_cc = val2 + else + min_cc = val1 end if return end function min_cc - complex * 16 function min_cr(val1, val2) - complex*16, intent(in) :: val1 - real*8, intent(in) :: val2 - if (real(val1) < val2) then - min_cr = val1 - else + complex(kind=8) function min_cr(val1, val2) + complex(kind=8), intent(in) :: val1 + real(kind=8), intent(in) :: val2 + if (real(val1) > val2) then min_cr = cmplx(val2, 0.) + else + min_cr = val1 end if return end function min_cr - complex * 16 function min_rc(val1, val2) - real*8, intent(in) :: val1 - complex*16, intent(in) :: val2 - if (val1 < real(val2)) then - min_rc = cmplx(val1, 0.) - else + complex(kind=8) function min_rc(val1, val2) + real(kind=8), intent(in) :: val1 + complex(kind=8), intent(in) :: val2 + if (val1 > real(val2)) then min_rc = val2 + else + min_rc = cmplx(val1, 0.) end if return end function min_rc - complex * 16 function min_ccc(val1, val2, val3) - complex*16, intent(in) :: val1, val2, val3 - if (real(val1) < real(val2)) then - min_ccc = val1 - else + complex(kind=8) function min_ccc(val1, val2, val3) + complex(kind=8), intent(in) :: val1, val2, val3 + if (real(val1) > real(val2)) then min_ccc = val2 + else + min_ccc = val1 end if - if (real(val3) < real(min_ccc)) then + + if (real(min_ccc) > real(val3)) then min_ccc = val3 end if return end function min_ccc function min_cccc(val1, val2, val3, val4) - complex*16, intent(in) :: val1, val2, val3, val4 - complex * 16 min_cccc - complex * 16 min_cccc2 - if (real(val1) < real(val2)) then - min_cccc = val1 - else + complex(kind=8), intent(in) :: val1, val2, val3, val4 + complex(kind=8) min_cccc + complex(kind=8) min_cccc2 + if (real(val1) > real(val2)) then min_cccc = val2 - end if - if (real(val3) < real(val4)) then - min_cccc2 = val3 else + min_cccc = val1 + end if + + if (real(val3) > real(val4)) then min_cccc2 = val4 + else + min_cccc2 = val3 end if - if (real(min_cccc2) < real(min_cccc)) then + if (real(min_cccc) > real(min_cccc2)) then min_cccc = min_cccc2 end if return end function min_cccc -! SIGN, intrinsic, assume that val1 is always a complex*16 +! MINVAL: minimum of an array +! Assumes a 1D array! + complex(kind=8) function minval_c(z) + complex(kind=8), intent(in) :: z(:) + minval_c = cmplx(minval(real(z)), aimag(z(minloc(real(z), dim=1)))) + end function minval_c + +! MAXVAL: maximum of an array +! Assumes a 1D array! + complex(kind=8) function maxval_c(z) + complex(kind=8), intent(in) :: z(:) + maxval_c = cmplx(maxval(real(z)), aimag(z(maxloc(real(z), dim=1)))) + end function maxval_c + +!! MINLOC: location of minimum in an array +! complex(kind=8) function minloc_c(z) +! complex(kind=8), intent(in) :: z(:) +! !integer n +! !n = size(z) +! minloc_c = minloc(real(z)) +! end function minval_c + +! SIGN, intrinsic, assume that val1 is always a complex(kind=8) ! in reality could be int - complex * 16 function sign_cc(val1, val2) - complex*16, intent(in) :: val1, val2 - real * 8 sign + complex(kind=8) function sign_cc(val1, val2) + complex(kind=8), intent(in) :: val1, val2 + real(kind=8) sign if (real(val2) < 0.) then sign = -1. else @@ -509,10 +555,27 @@ complex * 16 function sign_cc(val1, val2) sign_cc = sign * val1 return end function sign_cc - complex * 16 function sign_cr(val1, val2) - complex*16, intent(in) :: val1 - real*8, intent(in) :: val2 - real * 8 sign + function sign_cca(val1, val2) ! NEW, not verified + complex(kind=8), intent(in) :: val1 + complex(kind=8), intent(in) :: val2(:) + complex(kind=8) sign_cca(size(val2)) + real(kind=8) sign + integer i, n + n = size(val2) + do i = 1, n + if (real(val2(i)) < 0.) then + sign = -1. + else + sign = 1. + end if + sign_cca(i) = sign * val1 + end do + return + end function sign_cca + complex(kind=8) function sign_cr(val1, val2) + complex(kind=8), intent(in) :: val1 + real(kind=8), intent(in) :: val2 + real(kind=8) sign if (real(val2) < 0.) then sign = -1. else @@ -521,10 +584,10 @@ complex * 16 function sign_cr(val1, val2) sign_cr = sign * val1 return end function sign_cr - complex * 16 function sign_rc(val1, val2) - real*8, intent(in) :: val1 - complex*16, intent(in) :: val2 - real * 8 sign + complex(kind=8) function sign_rc(val1, val2) + real(kind=8), intent(in) :: val1 + complex(kind=8), intent(in) :: val2 + real(kind=8) sign if (real(val2) < 0.) then sign = -1. else @@ -535,8 +598,8 @@ complex * 16 function sign_rc(val1, val2) end function sign_rc ! DIM, intrinsic - complex * 16 function dim_cc(val1, val2) - complex*16, intent(in) :: val1, val2 + complex(kind=8) function dim_cc(val1, val2) + complex(kind=8), intent(in) :: val1, val2 if (val1 > val2) then dim_cc = val1 - val2 else @@ -544,9 +607,9 @@ complex * 16 function dim_cc(val1, val2) end if return end function dim_cc - complex * 16 function dim_cr(val1, val2) - complex*16, intent(in) :: val1 - real*8, intent(in) :: val2 + complex(kind=8) function dim_cr(val1, val2) + complex(kind=8), intent(in) :: val1 + real(kind=8), intent(in) :: val2 if (val1 > val2) then dim_cr = val1 - cmplx(val2, 0.) else @@ -554,9 +617,9 @@ complex * 16 function dim_cr(val1, val2) end if return end function dim_cr - complex * 16 function dim_rc(val1, val2) - real*8, intent(in) :: val1 - complex*16, intent(in) :: val2 + complex(kind=8) function dim_rc(val1, val2) + real(kind=8), intent(in) :: val1 + complex(kind=8), intent(in) :: val2 if (val1 > val2) then dim_rc = cmplx(val1, 0.) - val2 else @@ -566,109 +629,132 @@ complex * 16 function dim_rc(val1, val2) end function dim_rc ! LOG10 - complex * 16 function log10_c(z) - complex*16, intent(in) :: z + complex(kind=8) function log10_c(z) + complex(kind=8), intent(in) :: z log10_c = log(z) / log((10.0, 0.0)) end function log10_c ! NINT integer function nint_c(z) - complex*16, intent(in) :: z + complex(kind=8), intent(in) :: z nint_c = nint(real(z)) end function nint_c ! EPSILON !! bad news ulness compiled with -r8 - complex * 16 function epsilon_c(z) - complex*16, intent(in) :: z + complex(kind=8) function epsilon_c(z) + complex(kind=8), intent(in) :: z epsilon_c = epsilon(real(z)) end function epsilon_c ! <, .lt. logical function lt_cc(lhs, rhs) - complex*16, intent(in) :: lhs, rhs + complex(kind=8), intent(in) :: lhs, rhs lt_cc = real(lhs) < real(rhs) end function lt_cc logical function lt_cr(lhs, rhs) - complex*16, intent(in) :: lhs - real*8, intent(in) :: rhs + complex(kind=8), intent(in) :: lhs + real(kind=8), intent(in) :: rhs lt_cr = real(lhs) < rhs end function lt_cr logical function lt_rc(lhs, rhs) - real*8, intent(in) :: lhs - complex*16, intent(in) :: rhs + real(kind=8), intent(in) :: lhs + complex(kind=8), intent(in) :: rhs lt_rc = lhs < real(rhs) end function lt_rc logical function lt_ci(lhs, rhs) - complex*16, intent(in) :: lhs + complex(kind=8), intent(in) :: lhs integer, intent(in) :: rhs lt_ci = real(lhs) < rhs end function lt_ci logical function lt_ic(lhs, rhs) integer, intent(in) :: lhs - complex*16, intent(in) :: rhs + complex(kind=8), intent(in) :: rhs lt_ic = lhs < real(rhs) end function lt_ic ! <=, .le. logical function le_cc(lhs, rhs) - complex*16, intent(in) :: lhs, rhs + complex(kind=8), intent(in) :: lhs, rhs le_cc = real(lhs) <= real(rhs) end function le_cc logical function le_cr(lhs, rhs) - complex*16, intent(in) :: lhs - real*8, intent(in) :: rhs + complex(kind=8), intent(in) :: lhs + real(kind=8), intent(in) :: rhs le_cr = real(lhs) <= rhs end function le_cr logical function le_rc(lhs, rhs) - real*8, intent(in) :: lhs - complex*16, intent(in) :: rhs + real(kind=8), intent(in) :: lhs + complex(kind=8), intent(in) :: rhs le_rc = lhs <= real(rhs) end function le_rc logical function le_ci(lhs, rhs) - complex*16, intent(in) :: lhs + complex(kind=8), intent(in) :: lhs integer, intent(in) :: rhs le_ci = real(lhs) <= rhs end function le_ci logical function le_ic(lhs, rhs) integer, intent(in) :: lhs - complex*16, intent(in) :: rhs + complex(kind=8), intent(in) :: rhs le_ic = lhs <= real(rhs) end function le_ic ! >, .gt. logical function gt_cc(lhs, rhs) - complex*16, intent(in) :: lhs, rhs + complex(kind=8), intent(in) :: lhs, rhs gt_cc = real(lhs) > real(rhs) end function gt_cc logical function gt_cr(lhs, rhs) - complex*16, intent(in) :: lhs - real*8, intent(in) :: rhs + complex(kind=8), intent(in) :: lhs + real(kind=8), intent(in) :: rhs gt_cr = real(lhs) > rhs end function gt_cr logical function gt_rc(lhs, rhs) - real*8, intent(in) :: lhs - complex*16, intent(in) :: rhs + real(kind=8), intent(in) :: lhs + complex(kind=8), intent(in) :: rhs gt_rc = lhs > real(rhs) end function gt_rc logical function gt_ci(lhs, rhs) - complex*16, intent(in) :: lhs + complex(kind=8), intent(in) :: lhs integer, intent(in) :: rhs gt_ci = real(lhs) > rhs end function gt_ci logical function gt_ic(lhs, rhs) integer, intent(in) :: lhs - complex*16, intent(in) :: rhs + complex(kind=8), intent(in) :: rhs gt_ic = lhs > real(rhs) end function gt_ic +! function gt_caca(lhs, rhs) ! Arrays +! complex(kind=8), intent(in) :: lhs(:), rhs(:) +! logical gt_caca(size(lhs)) +! integer n +! n = size(lhs) +! gt_caca = real(lhs) > real(rhs) +! end function gt_caca + function gt_cac(lhs, rhs) ! Arrays + complex(kind=8), intent(in) :: lhs(:) + complex(kind=8), intent(in) :: rhs + logical gt_cac(size(lhs)) + integer n + n = size(lhs) + gt_cac = real(lhs) > real(rhs) + end function gt_cac + function gt_car(lhs, rhs) ! Arrays + complex(kind=8), intent(in) :: lhs(:) + real(kind=8), intent(in) :: rhs + logical gt_car(size(lhs)) + integer n + n = size(lhs) + gt_car = real(lhs) > rhs + end function gt_car !! here are the redefined ones: ! >=, .ge. logical function ge_cc(lhs, rhs) - complex*16, intent(in) :: lhs, rhs + complex(kind=8), intent(in) :: lhs, rhs ge_cc = real(lhs) >= real(rhs) end function ge_cc logical function ge_rr(lhs, rhs) - real*8, intent(in) :: lhs, rhs + real(kind=8), intent(in) :: lhs, rhs ge_rr = lhs >= rhs end function ge_rr logical function ge_ii(lhs, rhs) @@ -680,91 +766,112 @@ logical function ge_aa(lhs, rhs) ge_aa = lhs >= rhs end function ge_aa logical function ge_cr(lhs, rhs) - complex*16, intent(in) :: lhs - real*8, intent(in) :: rhs + complex(kind=8), intent(in) :: lhs + real(kind=8), intent(in) :: rhs ge_cr = real(lhs) >= rhs end function ge_cr logical function ge_rc(lhs, rhs) - real*8, intent(in) :: lhs - complex*16, intent(in) :: rhs + real(kind=8), intent(in) :: lhs + complex(kind=8), intent(in) :: rhs ge_rc = lhs >= real(rhs) end function ge_rc logical function ge_ci(lhs, rhs) - complex*16, intent(in) :: lhs + complex(kind=8), intent(in) :: lhs integer, intent(in) :: rhs ge_ci = real(lhs) >= rhs end function ge_ci logical function ge_ic(lhs, rhs) integer, intent(in) :: lhs - complex*16, intent(in) :: rhs + complex(kind=8), intent(in) :: rhs ge_ic = lhs >= real(rhs) end function ge_ic logical function ge_ir(lhs, rhs) integer, intent(in) :: lhs - real*8, intent(in) :: rhs + real(kind=8), intent(in) :: rhs ge_ir = lhs >= rhs end function ge_ir logical function ge_ri(lhs, rhs) - real*8, intent(in) :: lhs + real(kind=8), intent(in) :: lhs integer, intent(in) :: rhs ge_ri = lhs >= rhs end function ge_ri ! ==, .eq. logical function eq_cc(lhs, rhs) - complex*16, intent(in) :: lhs, rhs + complex(kind=8), intent(in) :: lhs, rhs eq_cc = real(lhs) == real(rhs) end function eq_cc logical function eq_rr(lhs, rhs) - real*8, intent(in) :: lhs, rhs + real(kind=8), intent(in) :: lhs, rhs eq_rr = lhs == rhs end function eq_rr logical function eq_ii(lhs, rhs) integer, intent(in) :: lhs, rhs eq_ii = lhs == rhs end function eq_ii + ! lhs and rhs are rank 1 integer arrays + function eq_iaia(lhs, rhs) + integer, intent(in) :: lhs(:), rhs(:) + logical eq_iaia(size(lhs)) + eq_iaia = lhs == rhs + end function eq_iaia + ! lhs is a rank 3 integer array + function eq_iai(lhs, rhs) + integer, intent(in) :: lhs(:, :, :) + integer, intent(in) :: rhs + logical eq_iai(size(lhs, 1), size(lhs, 2), size(lhs, 3)) + eq_iai = lhs == rhs + end function eq_iai + logical function eq_i8i8(lhs, rhs) + integer(kind=8), intent(in) :: lhs, rhs + eq_i8i8 = lhs == rhs + end function eq_i8i8 + logical function eq_i1i1(lhs, rhs) + integer(kind=1), intent(in) :: lhs, rhs + eq_i1i1 = lhs == rhs + end function eq_i1i1 logical function eq_aa(lhs, rhs) character(len=*), intent(in) :: lhs, rhs eq_aa = lhs == rhs end function eq_aa logical function eq_cr(lhs, rhs) - complex*16, intent(in) :: lhs - real*8, intent(in) :: rhs + complex(kind=8), intent(in) :: lhs + real(kind=8), intent(in) :: rhs eq_cr = real(lhs) == rhs end function eq_cr logical function eq_rc(lhs, rhs) - real*8, intent(in) :: lhs - complex*16, intent(in) :: rhs + real(kind=8), intent(in) :: lhs + complex(kind=8), intent(in) :: rhs eq_rc = lhs == real(rhs) end function eq_rc logical function eq_ci(lhs, rhs) - complex*16, intent(in) :: lhs + complex(kind=8), intent(in) :: lhs integer, intent(in) :: rhs eq_ci = real(lhs) == rhs end function eq_ci logical function eq_ic(lhs, rhs) integer, intent(in) :: lhs - complex*16, intent(in) :: rhs + complex(kind=8), intent(in) :: rhs eq_ic = lhs == real(rhs) end function eq_ic logical function eq_ir(lhs, rhs) integer, intent(in) :: lhs - real*8, intent(in) :: rhs + real(kind=8), intent(in) :: rhs eq_ir = lhs == rhs end function eq_ir logical function eq_ri(lhs, rhs) - real*8, intent(in) :: lhs + real(kind=8), intent(in) :: lhs integer, intent(in) :: rhs eq_ri = lhs == rhs end function eq_ri ! /=, .ne. logical function ne_cc(lhs, rhs) - complex*16, intent(in) :: lhs, rhs + complex(kind=8), intent(in) :: lhs, rhs ne_cc = real(lhs) /= real(rhs) end function ne_cc logical function ne_rr(lhs, rhs) - real*8, intent(in) :: lhs, rhs + real(kind=8), intent(in) :: lhs, rhs ne_rr = lhs /= rhs end function ne_rr logical function ne_ii(lhs, rhs) @@ -776,34 +883,43 @@ logical function ne_aa(lhs, rhs) ne_aa = lhs /= rhs end function ne_aa logical function ne_cr(lhs, rhs) - complex*16, intent(in) :: lhs - real*8, intent(in) :: rhs + complex(kind=8), intent(in) :: lhs + real(kind=8), intent(in) :: rhs ne_cr = real(lhs) /= rhs end function ne_cr logical function ne_rc(lhs, rhs) - real*8, intent(in) :: lhs - complex*16, intent(in) :: rhs + real(kind=8), intent(in) :: lhs + complex(kind=8), intent(in) :: rhs ne_rc = lhs /= real(rhs) end function ne_rc logical function ne_ci(lhs, rhs) - complex*16, intent(in) :: lhs + complex(kind=8), intent(in) :: lhs integer, intent(in) :: rhs ne_ci = real(lhs) /= rhs end function ne_ci logical function ne_ic(lhs, rhs) integer, intent(in) :: lhs - complex*16, intent(in) :: rhs + complex(kind=8), intent(in) :: rhs ne_ic = lhs /= real(rhs) end function ne_ic logical function ne_ir(lhs, rhs) integer, intent(in) :: lhs - real*8, intent(in) :: rhs + real(kind=8), intent(in) :: rhs ne_ir = lhs /= rhs end function ne_ir logical function ne_ri(lhs, rhs) - real*8, intent(in) :: lhs + real(kind=8), intent(in) :: lhs integer, intent(in) :: rhs ne_ri = lhs /= rhs end function ne_ri +! floor: the largest integer less than or equal to the argument + function floor_c(z) + complex(kind=8), intent(in) :: z(:) + complex(kind=8) floor_c(size(z)) + integer n + n = size(z) + floor_c = floor(real(z(1:n))) + end function floor_c + end module complexify diff --git a/src/common/precision.F90 b/src/common/precision.F90 index ab4730a..72fdf94 100644 --- a/src/common/precision.F90 +++ b/src/common/precision.F90 @@ -30,11 +30,9 @@ module precision ! ****************************************************************** ! ! + use mpi implicit none save -#ifndef USE_TAPENADE -#include "mpif.h" -#endif ! ! ****************************************************************** ! * * diff --git a/src/curveSearch/curveUtils.F90 b/src/curveSearch/curveUtils.F90 index c94c927..02a5418 100644 --- a/src/curveSearch/curveUtils.F90 +++ b/src/curveSearch/curveUtils.F90 @@ -13,7 +13,7 @@ subroutine barProjection(x1, x2, x, xf, u) ! ! Ney Secco 2016-11 - use Utilities ! This will bring dot + use utilities ! This will bring dot implicit none ! DECLARATIONS @@ -60,7 +60,7 @@ subroutine computeTangent(x1, x2, tangent) ! ! Ney Secco 2016-11 - use Utilities + use utilities implicit none ! DECLARATIONS @@ -80,7 +80,7 @@ subroutine computeTangent(x1, x2, tangent) ! Get the relative vectors for the bar element x21 = x2 - x1 - ! Normalize vector (dot defined in Utilities.F90) + ! Normalize vector (dot defined in utilities.F90) dummyVec = x21 call dot(x21, dummyVec, dotResult) tangent = x21 / sqrt(dotResult) diff --git a/src/intersections/Makefile b/src/intersections/Makefile index 4dc84df..acf9730 100644 --- a/src/intersections/Makefile +++ b/src/intersections/Makefile @@ -5,11 +5,11 @@ include ${COMMON_FILE} include ${RULES_FILE} vpath %.o $(OBJDIR) -FF90_OBJECTS_1 = Intersection.o +FF90_OBJECTS_1 = intersection.o FF90_OBJECTS_2 = intersectionAPI.o -FILES_TO_COMPLEXIFY = Intersection.F90 \ +FILES_TO_COMPLEXIFY = intersection.F90 \ intersectionAPI.F90 default: all diff --git a/src/intersections/Intersection.F90 b/src/intersections/intersection.F90 similarity index 99% rename from src/intersections/Intersection.F90 rename to src/intersections/intersection.F90 index cbcb6fa..2124974 100644 --- a/src/intersections/Intersection.F90 +++ b/src/intersections/intersection.F90 @@ -1,6 +1,6 @@ -module Intersection +module intersection - use Utilities + use utilities use precision implicit none @@ -893,4 +893,4 @@ subroutine sort(a, b, smallest) end subroutine sort -end module Intersection +end module intersection diff --git a/src/intersections/intersectionAPI.F90 b/src/intersections/intersectionAPI.F90 index bfa7a81..42eba14 100644 --- a/src/intersections/intersectionAPI.F90 +++ b/src/intersections/intersectionAPI.F90 @@ -74,8 +74,8 @@ subroutine computeIntersection(nNodesA, nTriaA, nQuadsA, & ! ! Ney Secco 2016-08 - use Intersection - use Utilities ! This will bring condenseBarNodes_main + use intersection + use utilities ! This will bring condenseBarNodes_main use adtAPI ! This will bring adtBuildSurfaceADT and adtIntersectionSearch implicit none @@ -447,9 +447,9 @@ subroutine computeIntersection_b(nNodesA, nTriaA, nQuadsA, & ! ! Ney Secco 2016-09 - use Intersection - use Intersection_b, only: triTriIntersect_b - use Utilities ! This will bring condenseBarNodes_main + use intersection + use intersection_b, only: triTriIntersect_b + use utilities ! This will bring condenseBarNodes_main implicit none ! Input variables @@ -723,9 +723,9 @@ subroutine computeIntersection_d(nNodesA, nTriaA, nQuadsA, & ! ! Ney Secco 2016-09 - use Intersection - use Intersection_d, only: triTriIntersect_d - use Utilities ! This will bring condenseBarNodes_main + use intersection + use intersection_d, only: triTriIntersect_d + use utilities ! This will bring condenseBarNodes_main implicit none ! Input variables @@ -995,9 +995,9 @@ subroutine testTri(V0, V1, V2, U0, U1, U2, intersect, vecStart, vecEnd) ! John Jasa 2016-08 ! Ney Secco 2017-01: added derivative checks - use Intersection, only: triTriIntersect - use Intersection_b, only: triTriIntersect_b - use Intersection_d, only: triTriIntersect_d + use intersection, only: triTriIntersect + use intersection_b, only: triTriIntersect_b + use intersection_d, only: triTriIntersect_d implicit none real(kind=realType), dimension(3), intent(in) :: V0, V1, V2, U0, U1, U2 diff --git a/src/intersections/test.F90 b/src/intersections/test.F90 index 7cec641..a871be8 100644 --- a/src/intersections/test.F90 +++ b/src/intersections/test.F90 @@ -1,7 +1,7 @@ program test use precision - use Intersection + use intersection implicit none real(kind=realType), dimension(:, :), allocatable :: coor diff --git a/src/utilities/Makefile b/src/utilities/Makefile index a9d24c9..73f28d1 100644 --- a/src/utilities/Makefile +++ b/src/utilities/Makefile @@ -5,11 +5,11 @@ include ${COMMON_FILE} include ${RULES_FILE} vpath %.o $(OBJDIR) -FF90_OBJECTS_1 = Utilities.o +FF90_OBJECTS_1 = utilities.o FF90_OBJECTS_2 = utilitiesAPI.o -FILES_TO_COMPLEXIFY = Utilities.F90 \ +FILES_TO_COMPLEXIFY = utilities.F90 \ utilitiesAPI.F90 default: all @@ -20,7 +20,7 @@ all: cp -f *.mod $(MODDIR) clean: - @echo " Making clean in Utilities... " + @echo " Making clean in utilities... " rm -f $(MAKE_CLEAN_ARGUMENTS) complexify: diff --git a/src/utilities/Utilities.F90 b/src/utilities/utilities.F90 similarity index 99% rename from src/utilities/Utilities.F90 rename to src/utilities/utilities.F90 index 21c08ab..87acbae 100644 --- a/src/utilities/Utilities.F90 +++ b/src/utilities/utilities.F90 @@ -1,4 +1,4 @@ -module Utilities +module utilities use precision implicit none @@ -861,4 +861,4 @@ subroutine lineIntersectionInterval(xminA, xmaxA, xminB, xmaxB, xminAB, xmaxAB, end subroutine lineIntersectionInterval -end module Utilities +end module utilities